1# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2# 2001, 2002, 2003 Free Software Foundation, Inc. 3# 4# This file is part of DejaGnu. 5# 6# DejaGnu is free software; you can redistribute it and/or modify it 7# under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# DejaGnu is distributed in the hope that it will be useful, but 12# WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14# General Public License for more details. 15# 16# You should have received a copy of the GNU General Public License 17# along with DejaGnu; if not, write to the Free Software Foundation, 18# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 19 20# This file was written by Rob Savoye. (rob@welcomehome.org) 21 22# load various protocol support modules 23 24load_lib "mondfe.exp" 25load_lib "xsh.exp" 26load_lib "telnet.exp" 27load_lib "rlogin.exp" 28load_lib "kermit.exp" 29load_lib "tip.exp" 30load_lib "rsh.exp" 31load_lib "ftp.exp" 32 33# 34# Open a connection to a remote host or target. This requires the target_info 35# array be filled in with the proper info to work. 36# 37# type is either "build", "host", "target", or the name of a board loaded 38# into the board_info array. The default is target if no name is supplied. 39# It returns the spawn id of the process that is the connection. 40# 41 42proc remote_open { args } { 43 global reboot 44 45 if { [llength $args] == 0 } { 46 set type "target" 47 } else { 48 set type $args 49 } 50 51 # Shudder... 52 if { $reboot && $type == "target" } { 53 reboot_target 54 } 55 56 return [call_remote "" open $type] 57} 58 59proc remote_raw_open { args } { 60 return [eval call_remote raw open $args] 61} 62 63# Run the specified COMMANDLINE on the local machine, redirecting input 64# to file INP (if non-empty), redirecting output to file OUTP (if non-empty), 65# and waiting TIMEOUT seconds for the command to complete before killing 66# it. A two-member list is returned; the first member is the exit status 67# of the command, the second is any output produced from the command 68# (if output is redirected, this may or may not be empty). If output is 69# redirected, both stdout and stderr will appear in the specified file. 70# 71# Caveats: A pipeline is used if input or output is redirected. There 72# will be problems with killing the program if a pipeline is used. Either 73# the "tee" command or the "cat" command is used in the pipeline if input 74# or output is redirected. If the program needs to be killed, /bin/sh and 75# the kill command will be invoked. 76# 77proc local_exec { commandline inp outp timeout } { 78 # Tcl's exec is a pile of crap. It does two very inappropriate things 79 # firstly, it has no business returning an error if the program being 80 # executed happens to write to stderr. Secondly, it appends its own 81 # error messages to the output of the command if the process exits with 82 # non-zero status. 83 # 84 # So, ok, we do this funny stuff with using spawn sometimes and 85 # open others because of spawn's inability to invoke commands with 86 # redirected I/O. We also hope that nobody passes in a command that's 87 # a pipeline, because spawn can't handle it. 88 # 89 # We want to use spawn in most cases, because tcl's pipe mechanism 90 # doesn't assign process groups correctly and we can't reliably kill 91 # programs that bear children. We can't use tcl's exec because it has 92 # no way to timeout programs that hang. *sigh* 93 # 94 if { "$inp" == "" && "$outp" == "" } { 95 set id -1 96 set result [catch "eval spawn \{${commandline}\}" pid] 97 if { $result == 0 } { 98 set result2 0 99 } else { 100 set pid 0 101 set result2 5 102 } 103 } else { 104 # Can you say "uuuuuugly"? I knew you could! 105 # All in the name of non-infinite hangs. 106 if { $inp != "" } { 107 set inp "< $inp" 108 set mode "r" 109 } else { 110 set mode "w" 111 } 112 113 set use_tee 0 114 # We add |& cat so that Tcl exec doesn't freak out if the 115 # program writes to stderr. 116 if { $outp == "" } { 117 set outp "|& cat" 118 } else { 119 set outpf "$outp" 120 set outp "> $outp" 121 if { $inp != "" } { 122 set use_tee 1 123 } 124 } 125 # Why do we use tee? Because open can't redirect both input and output. 126 if { $use_tee } { 127 set result [catch {open "| ${commandline} $inp |& tee $outpf" RDONLY} id] 128 } else { 129 set result [catch {open "| ${commandline} $inp $outp" $mode} id] 130 } 131 132 if { $result != 0 } { 133 global errorInfo 134 return [list -1 "open of $commandline $inp $outp failed: $errorInfo"] 135 } 136 set pid [pid $id] 137 set result [catch "spawn -leaveopen $id" result2] 138 } 139 # Prepend "-" to each pid, to generate the "process group IDs" needed by 140 # kill. 141 set pgid "-[join $pid { -}]" 142 verbose "pid is $pid $pgid" 143 if { $result != 0 || $result2 != 0 } { 144 # This shouldn't happen. 145 global errorInfo 146 if [info exists errorInfo] { 147 set foo $errorInfo 148 } else { 149 set foo "" 150 } 151 verbose "spawn -open $id failed, $result $result2, $foo" 152 catch "close $id" 153 return [list -1 "spawn failed"] 154 } 155 156 set got_eof 0 157 set output "" 158 159 # Wait for either $timeout seconds to elapse, or for the program to 160 # exit. 161 expect { 162 -i $spawn_id -timeout $timeout -re ".+" { 163 append output $expect_out(buffer) 164 if { [string length $output] < 512000 } { 165 exp_continue -continue_timer 166 } 167 } 168 timeout { 169 warning "program timed out." 170 } 171 eof { 172 set got_eof 1 173 } 174 } 175 176 # Uuuuuuugh. Now I'm getting really sick. 177 # If we didn't get an EOF, we have to kill the poor defenseless program. 178 # However, Tcl has no kill primitive, so we have to execute an external 179 # command in order to execute the execution. (English. Gotta love it.) 180 if { ! $got_eof } { 181 verbose "killing $pid $pgid" 182 # This is very, very nasty. SH, instead of EXPECT, is used to 183 # run this in the background since, on older CYGWINs, a 184 # strange file I/O error occures. 185 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) &" 186 } 187 # This will hang if the kill doesn't work. Nothin' to do, and it's not ok. 188 catch "close -i $spawn_id" 189 set r2 [catch "wait -i $spawn_id" wres] 190 if { $id > 0 } { 191 set r2 [catch "close $id" res] 192 } else { 193 verbose "waitres is $wres" 2 194 if { $r2 == 0 } { 195 set r2 [lindex $wres 3] 196 if { [llength $wres] > 4 } { 197 if { [lindex $wres 4] == "CHILDKILLED" } { 198 set r2 1 199 } 200 } 201 if { $r2 != 0 } { 202 set res "$wres" 203 } else { 204 set res "" 205 } 206 } else { 207 set res "wait failed" 208 } 209 } 210 if { $r2 != 0 || $res != "" || ! $got_eof } { 211 verbose "close result is $res" 212 set status 1 213 } else { 214 set status 0 215 } 216 verbose "output is $output" 217 if { $outp == "" } { 218 return [list $status $output] 219 } else { 220 return [list $status ""] 221 } 222} 223 224# 225# Execute the supplied program on HOSTNAME. There are four optional arguments 226# the first is a set of arguments to pass to PROGRAM, the second is an 227# input file to feed to stdin of PROGRAM, the third is the name of an 228# output file where the output from PROGRAM should be written, and 229# the fourth is a timeout value (we give up after the specified # of seconds 230# has elapsed). 231# 232# A two-element list is returned. The first value is the exit status of the 233# program (-1 if the exec failed). The second is any output produced by 234# the program (which may or may not be empty if output from the program was 235# redirected). 236# 237proc remote_exec { hostname program args } { 238 if { [llength $args] > 0 } { 239 set pargs [lindex $args 0] 240 } else { 241 set pargs "" 242 } 243 244 if { [llength $args] > 1 } { 245 set inp "[lindex $args 1]" 246 } else { 247 set inp "" 248 } 249 250 if { [llength $args] > 2 } { 251 set outp "[lindex $args 2]" 252 } else { 253 set outp "" 254 } 255 256 # 300 is probably a lame default. 257 if { [llength $args] > 3 } { 258 set timeout "[lindex $args 3]" 259 } else { 260 set timeout 300 261 } 262 263 verbose -log "Executing on $hostname: $program $pargs $inp $outp (timeout = $timeout)" 2 264 265 # Run it locally if appropriate. 266 if { ![is_remote $hostname] } { 267 return [local_exec "$program $pargs" $inp $outp $timeout] 268 } else { 269 return [call_remote "" exec $hostname $program $pargs $inp $outp] 270 } 271} 272 273proc standard_exec { hostname args } { 274 return [eval rsh_exec \"$hostname\" $args] 275} 276 277# 278# Close the remote connection. 279# arg - This is the name of the machine whose connection we're closing, 280# or target, host or build. 281# 282 283proc remote_close { host } { 284 while { 1 } { 285 set result [call_remote "" close "$host"] 286 if { [remote_pop_conn $host] != "pass" } { 287 break 288 } 289 } 290 return $result 291} 292 293proc remote_raw_close { host } { 294 return [call_remote raw close "$host"] 295} 296 297proc standard_close { host } { 298 global board_info 299 300 if [board_info ${host} exists fileid] { 301 set shell_id [board_info ${host} fileid] 302 set pid -1 303 304 verbose "Closing the remote shell $shell_id" 2 305 if [board_info ${host} exists fileid_origid] { 306 set oid [board_info ${host} fileid_origid] 307 set pid [pid $oid] 308 unset board_info(${host},fileid_origid) 309 } else { 310 set result [catch "exp_pid -i $shell_id" pid] 311 if { $result != 0 || $pid <= 0 } { 312 set result [catch "pid $shell_id" pid] 313 if { $result != 0 } { 314 set pid -1 315 } 316 } 317 } 318 if { $pid > 0 } { 319 verbose "doing kill, pid is $pid" 320 # This is very, very nasty. SH, instead of EXPECT, is used 321 # to run this in the background since, on older CYGWINs, a 322 # strange file I/O error occures. 323 set pgid "-[join $pid { -}]" 324 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) &" 325 } 326 verbose "pid is $pid" 327 catch "close -i $shell_id" 328 if [info exists oid] { 329 catch "close $oid" 330 } 331 catch "wait -i $shell_id" 332 unset board_info(${host},fileid) 333 verbose "Shell closed." 334 } 335 return 0 336} 337 338# 339# Set the connection into "binary" mode, a.k.a. no processing of input 340# characters. 341# 342proc remote_binary { host } { 343 return [call_remote "" binary "$host"] 344} 345 346proc remote_raw_binary { host } { 347 return [call_remote raw binary "$host"] 348} 349 350 351 352proc remote_reboot { host } { 353 clone_output "\nRebooting ${host}\n" 354 # FIXME: don't close the host connection, or all the remote 355 # procedures will fail. 356 # remote_close $host 357 set status [call_remote "" reboot "$host"] 358 if [board_info $host exists name] { 359 set host [board_info $host name] 360 } 361 if { [info proc ${host}_init] != "" } { 362 ${host}_init $host 363 } 364 return $status 365} 366 367proc standard_reboot { host } { 368 return "" 369} 370# 371# Download file FILE to DEST. If the optional DESTFILE is specified, 372# that file will be used on the destination board. It returns either 373# "" (indicating that the download failed), or the name of the file on 374# the destination machine. 375# 376 377proc remote_download { dest file args } { 378 if { [llength $args] > 0 } { 379 set destfile [lindex $args 0] 380 } else { 381 set destfile [file tail $file] 382 } 383 384 if { ![is_remote $dest] } { 385 if { $destfile == "" || $destfile == $file } { 386 return $file 387 } else { 388 set result [catch "exec cp -p $file $destfile" output] 389 if [regexp "same file|are identical" $output] { 390 set result 0 391 set output "" 392 } else { 393 # try to make sure we can read it 394 # and write it (in case we copy onto it again) 395 catch {exec chmod u+rw $destfile} 396 } 397 if { $result != 0 || $output != "" } { 398 perror "remote_download to $dest of $file to $destfile: $output" 399 return "" 400 } else { 401 return $destfile 402 } 403 } 404 } 405 406 return [call_remote "" download $dest $file $destfile] 407} 408 409# 410# The default download procedure. Uses rcp to download to $dest. 411# 412 413proc standard_download {dest file destfile} { 414 set orig_destfile $destfile 415 416 if [board_info $dest exists nfsdir] { 417 set destdir [board_info $dest nfsdir] 418 if [board_info $dest exists nfsroot_server] { 419 set dest [board_info $dest nfsroot_server] 420 } else { 421 set dest "" 422 } 423 set destfile "$destdir/$destfile" 424 } 425 426 if { "$dest" != "" } { 427 set result [rsh_download $dest $file $destfile] 428 if { $result == $destfile } { 429 return $orig_destfile 430 } else { 431 return $result 432 } 433 } 434 435 set result [catch "exec cp -p $file $destfile" output] 436 if [regexp "same file|are identical" $output] { 437 set result 0 438 set output "" 439 } else { 440 # try to make sure we can read it 441 # and write it (in case we copy onto it again) 442 catch {exec chmod u+rw $destfile} 443 } 444 if { $result != 0 || $output != "" } { 445 perror "remote_download to $dest of $file to $destfile: $output" 446 return "" 447 } else { 448 return $orig_destfile 449 } 450} 451 452proc remote_upload {dest srcfile args} { 453 if { [llength $args] > 0 } { 454 set destfile [lindex $args 0] 455 } else { 456 set destfile [file tail $srcfile] 457 } 458 459 if { ![is_remote $dest] } { 460 if { $destfile == "" || $srcfile == $destfile } { 461 return $srcfile 462 } 463 set result [catch "exec cp -p $srcfile $destfile" output] 464 return $destfile 465 } 466 467 return [call_remote "" upload $dest $srcfile $destfile] 468} 469 470proc standard_upload { dest srcfile destfile } { 471 set orig_srcfile $srcfile 472 473 if [board_info $dest exists nfsdir] { 474 set destdir [board_info $dest nfsdir] 475 if [board_info $dest exists nfsroot_server] { 476 set dest [board_info $dest nfsroot_server] 477 } else { 478 set dest "" 479 } 480 set srcfile "$destdir/$srcfile" 481 } 482 483 if { "$dest" != "" } { 484 return [rsh_upload $dest $srcfile $destfile] 485 } 486 487 set result [catch "exec cp -p $srcfile $destfile" output] 488 if [regexp "same file|are identical" $output] { 489 set result 0 490 set output "" 491 } else { 492 # try to make sure we can read it 493 # and write it (in case we copy onto it again) 494 catch {exec chmod u+rw $destfile} 495 } 496 if { $result != 0 || $output != "" } { 497 perror "remote_upload to $dest of $file to $destfile: $output" 498 return "" 499 } else { 500 return $destfile 501 } 502 503 return [rsh_upload $dest $srcfile $destfile] 504} 505 506# 507# A standard procedure to call the appropriate function. It first looks 508# for a board-specific version, then a version specific to the protocol, 509# and then finally it will call standard_$proc. 510# 511 512proc call_remote { type proc dest args } { 513 if [board_info $dest exists name] { 514 set dest [board_info $dest name] 515 } 516 517 if { $dest != "host" && $dest != "build" && $dest != "target" } { 518 if { ![board_info $dest exists name] } { 519 global board 520 521 if [info exists board] { 522 blooie 523 } 524 load_board_description $dest 525 } 526 } 527 528 set high_prot "" 529 if { $type != "raw" } { 530 if [board_info $dest exists protocol] { 531 set high_prot "${dest} [board_info $dest protocol]" 532 } else { 533 set high_prot "${dest} [board_info $dest generic_name]" 534 } 535 } 536 537 verbose "call_remote $type $proc $dest $args " 3 538 # Close has to be handled specially. 539 if { $proc == "close" || $proc == "open" } { 540 foreach try "$high_prot [board_info $dest connect] telnet standard" { 541 if { $try != "" } { 542 if { [info proc "${try}_${proc}"] != "" } { 543 verbose "call_remote calling ${try}_${proc}" 3 544 set result [eval ${try}_${proc} \"$dest\" $args] 545 break 546 } 547 } 548 } 549 set ft "[board_info $dest file_transfer]" 550 if { [info proc "${ft}_${proc}"] != "" } { 551 verbose "calling ${ft}_${proc} $dest $args" 3 552 set result2 [eval ${ft}_${proc} \"$dest\" $args] 553 } 554 if ![info exists result] { 555 if [info exists result2] { 556 set result $result2 557 } else { 558 set result "" 559 } 560 } 561 return $result 562 } 563 foreach try "${high_prot} [board_info $dest file_transfer] [board_info $dest connect] telnet standard" { 564 verbose "looking for ${try}_${proc}" 4 565 if { $try != "" } { 566 if { [info proc "${try}_${proc}"] != "" } { 567 verbose "call_remote calling ${try}_${proc}" 3 568 return [eval ${try}_${proc} \"$dest\" $args] 569 } 570 } 571 } 572 if { $proc == "close" } { 573 return "" 574 } 575 error "No procedure for '$proc' in call_remote" 576 return -1 577} 578 579# 580# Send FILE through the existing session established to DEST. 581# 582proc remote_transmit { dest file } { 583 return [call_remote "" transmit "$dest" "$file"] 584} 585 586proc remote_raw_transmit { dest file } { 587 return [call_remote raw transmit "$dest" "$file"] 588} 589 590# 591# The default transmit procedure if no other exists. This feeds the 592# supplied file directly into the connection. 593# 594proc standard_transmit {dest file} { 595 if [board_info ${dest} exists name] { 596 set dest [board_info ${dest} name] 597 } 598 if [board_info ${dest} exists baud] { 599 set baud [board_info ${dest} baud] 600 } else { 601 set baud 9600 602 } 603 set shell_id [board_info ${dest} fileid] 604 605 set lines 0 606 set chars 0 607 set fd [open $file r] 608 while { [gets $fd cur_line] >= 0 } { 609 set errmess "" 610 catch "send -i $shell_id \"$cur_line\r\"" errmess 611 if [string match "write\(spawn_id=\[0-9\]+\):" $errmess] { 612 perror "sent \"$cur_line\" got expect error \"$errmess\"" 613 catch "close $fd" 614 return -1 615 } 616 set chars [expr $chars + ([string length $cur_line] * 10)] 617 if { $chars > $baud } { 618 sleep 1 619 set chars 0 620 } 621 verbose "." 3 622 verbose "Sent $cur_line" 4 623 incr lines 624 } 625 verbose "$lines lines transmitted" 2 626 close $fd 627 return 0 628} 629 630proc remote_send { dest string } { 631 return [call_remote "" send "$dest" "$string"] 632} 633 634proc remote_raw_send { dest string } { 635 return [call_remote raw send "$dest" "$string"] 636} 637 638proc standard_send { dest string } { 639 if ![board_info $dest exists fileid] { 640 perror "no fileid for $dest" 641 return "no fileid for $dest" 642 } else { 643 set shell_id [board_info $dest fileid] 644 verbose "shell_id in standard_send is $shell_id" 3 645 verbose "send -i [board_info $dest fileid] -- {$string}" 3 646 if [catch "send -i [board_info $dest fileid] -- {$string}" errorInfo] { 647 return "$errorInfo" 648 } else { 649 return "" 650 } 651 } 652} 653 654proc file_on_host { op file args } { 655 return [eval remote_file host \"$op\" \"$file\" $args] 656} 657 658proc file_on_build { op file args } { 659 return [eval remote_file build \"$op\" \"$file\" $args] 660} 661 662proc remote_file { dest args } { 663 return [eval call_remote \"\" file \"$dest\" $args] 664} 665 666proc remote_raw_file { dest args } { 667 return [eval call_remote raw file \"$dest\" $args] 668} 669 670# 671# Perform the specified file op on a remote Unix board. 672# 673 674proc standard_file { dest op args } { 675 set file [lindex $args 0] 676 verbose "dest in proc standard_file is $dest" 3 677 if { ![is_remote $dest] } { 678 switch $op { 679 cmp { 680 set otherfile [lindex $args 1] 681 if { [file exists $file] && [file exists $otherfile] 682 && [file size $file] == [file size $otherfile] } { 683 set r [remote_exec build cmp "$file $otherfile"] 684 if { [lindex $r 0] == 0 } { 685 return 0 686 } 687 } 688 return 1 689 } 690 tail { 691 return [file tail $file] 692 } 693 dirname { 694 if { [file pathtype $file] == "relative" } { 695 set file [remote_file $dest absolute $file] 696 } 697 set result [file dirname $file] 698 if { $result == "" } { 699 return "/" 700 } 701 return $result 702 } 703 join { 704 return [file join [lindex $args 0] [lindex $args 1]] 705 } 706 absolute { 707 return [unix_clean_filename $dest $file] 708 } 709 exists { 710 return [file exists $file] 711 } 712 delete { 713 foreach x $args { 714 if { [file exists $x] && [file isfile $x] } { 715 exec rm -f $x 716 } 717 } 718 return 719 } 720 } 721 } 722 switch $op { 723 exists { 724 # mmmm, quotes. 725 set status [remote_exec $dest "sh -c 'exit `\[ -f $file \]`'"] 726 return [lindex $status 0] 727 } 728 delete { 729 set file "" 730 # Allow multiple files to be deleted at once. 731 foreach x $args { 732 append file " $x" 733 } 734 verbose "remote_file deleting $file" 735 set status [remote_exec $dest "rm -f $file"] 736 return [lindex $status 0] 737 } 738 } 739} 740 741# 742# Return an absolute version of the filename in $file, with . and .. 743# removed. 744# 745proc unix_clean_filename { dest file } { 746 if { [file pathtype $file] == "relative" } { 747 set file [remote_file $dest join [pwd] $file] 748 } 749 set result "" 750 foreach x [split $file "/"] { 751 if { $x == "." || $x == "" } { 752 continue 753 } 754 if { $x == ".." } { 755 set rlen [expr [llength $result] - 2] 756 if { $rlen >= 0 } { 757 set result [lrange $result 0 $rlen] 758 } else { 759 set result "" 760 } 761 continue 762 } 763 lappend result $x 764 } 765 return "/[join $result /]" 766} 767 768# 769# Start COMMANDLINE running on DEST. By default it is not possible to 770# redirect I/O. If the optional keyword "readonly" is specified, input 771# to the command may be redirected. If the optional keyword 772# "writeonly" is specified, output from the command may be redirected. 773# 774# If the command is successfully started, a positive "spawn id" is returned. 775# If the spawn fails, a negative value will be returned. 776# 777# Once the command is spawned, you can interact with it via the remote_expect 778# and remote_wait functions. 779# 780proc remote_spawn { dest commandline args } { 781 global board_info 782 783 if ![is_remote $dest] { 784 if [info exists board_info($dest,fileid)] { 785 unset board_info($dest,fileid) 786 } 787 verbose "remote_spawn is local" 3 788 if [board_info $dest exists name] { 789 set dest [board_info $dest name] 790 } 791 792 verbose "spawning command $commandline" 793 794 if { [llength $args] > 0 } { 795 if { [lindex $args 0] == "readonly" } { 796 set result [catch { open "| ${commandline} |& cat" "r" } id] 797 if { $result != 0 } { 798 return -1 799 } 800 } else { 801 set result [catch {open "| ${commandline}" "w"} id] 802 if { $result != 0 } { 803 return -1 804 } 805 } 806 set result [catch "spawn -leaveopen $id" result2] 807 if { $result == 0 && $result2 == 0} { 808 verbose "setting board_info($dest,fileid) to $spawn_id" 3 809 set board_info($dest,fileid) $spawn_id 810 set board_info($dest,fileid_origid) $id 811 return $spawn_id 812 } else { 813 # This shouldn't happen. 814 global errorInfo 815 if [info exists errorInfo] { 816 set foo $errorInfo 817 } else { 818 set foo "" 819 } 820 verbose "spawn -open $id failed, $result $result2, $foo" 821 catch "close $id" 822 return -1 823 } 824 } else { 825 set result [catch "spawn $commandline" pid] 826 if { $result == 0 } { 827 verbose "setting board_info($dest,fileid) to $spawn_id" 3 828 set board_info($dest,fileid) $spawn_id 829 return $spawn_id 830 } else { 831 verbose -log "spawn of $commandline failed" 832 return -1 833 } 834 } 835 } 836 837 # Seems to me there should be a cleaner way to do this. 838 if { "$args" == "" } { 839 return [call_remote "" spawn "$dest" "$commandline"] 840 } else { 841 return [call_remote "" spawn "$dest" "$commandline" $args] 842 } 843} 844 845proc remote_raw_spawn { dest commandline } { 846 return [call_remote raw spawn "$dest" "$commandline"] 847} 848 849# 850# The default spawn procedure. Uses rsh to connect to $dest. 851# 852proc standard_spawn { dest commandline } { 853 global board_info 854 855 if ![board_info $dest exists rsh_prog] { 856 if { [which remsh] != 0 } { 857 set RSH remsh 858 } else { 859 set RSH rsh 860 } 861 } else { 862 set RSH [board_info $dest rsh_prog] 863 } 864 865 if ![board_info $dest exists username] { 866 set rsh_useropts "" 867 } else { 868 set rsh_useropts "-l $username" 869 } 870 871 if [board_info $dest exists hostname] { 872 set remote [board_info $dest hostname] 873 } else { 874 set remote $dest 875 } 876 877 spawn $RSH $rsh_useropts $remote $commandline 878 set board_info($dest,fileid) $spawn_id 879 return $spawn_id 880} 881 882# 883# Run PROG on DEST, with optional arguments, input and output files. 884# It returns a list of two items. The first is ether "pass" if the program 885# loaded, ran and exited with a zero exit status, or "fail" otherwise. 886# The second argument is any output produced by the program while it was 887# running. 888# 889proc remote_load { dest prog args } { 890 global tool 891 892 set dname [board_info $dest name] 893 set cache "[getenv REMOTELOAD_CACHE]/$tool/$dname/[file tail $prog]" 894 set empty [is_remote $dest] 895 if { [board_info $dest exists is_simulator] || [getenv REMOTELOAD_CACHE] == "" } { 896 set empty 0 897 } else { 898 for { set x 0 } {$x < [llength $args] } {incr x} { 899 if { [lindex $args $x] != "" } { 900 set empty 0 901 break 902 } 903 } 904 } 905 if $empty { 906 global sum_program 907 908 if [info exists sum_program] { 909 if ![target_info exists objcopy] { 910 set_currtarget_info objcopy [find_binutils_prog objcopy] 911 } 912 if [is_remote host] { 913 set dprog [remote_download host $prog "a.out"] 914 } else { 915 set dprog $prog 916 } 917 set status [remote_exec host "[target_info objcopy]" "-O srec $dprog ${dprog}.sum"] 918 if [is_remote host] { 919 remote_file upload ${dprog}.sum ${prog}.sum 920 } 921 if { [lindex $status 0] == 0 } { 922 set sumout [remote_exec build "$sum_program" "${prog}.sum"] 923 set sum [lindex $sumout 1] 924 regsub "\[\r\n \t\]+$" "$sum" "" sum 925 } else { 926 set sumout [remote_exec build "$sum_program" "${prog}"] 927 set sum [lindex $sumout 1] 928 regsub "\[\r\n \t\]+$" "$sum" "" sum 929 } 930 remote_file build delete ${prog}.sum 931 } 932 if [file exists $cache] { 933 set same 0 934 if [info exists sum_program] { 935 set id [open $cache "r"] 936 set oldsum [read $id] 937 close $id 938 if { $oldsum == $sum } { 939 set same 1 940 } 941 } else { 942 if { [remote_file build cmp $prog $cache] == 0 } { 943 set same 1 944 } 945 } 946 if { $same } { 947 set fd [open "${cache}.res" "r"] 948 gets $fd l1 949 set result [list $l1 [read $fd]] 950 close $fd 951 } 952 } 953 } 954 if ![info exists result] { 955 set result [eval call_remote \"\" load \"$dname\" \"$prog\" $args] 956 # Not quite happy about the "pass" condition, but it makes sense if 957 # you think about it for a while-- *why* did the test not pass? 958 if { $empty && [lindex $result 0] == "pass" } { 959 if { [getenv LOAD_REMOTECACHE] != "" } { 960 set dir "[getenv REMOTELOAD_CACHE]/$tool/$dname" 961 if ![file exists $dir] { 962 file mkdir $dir 963 } 964 if [file exists $dir] { 965 if [info exists sum_program] { 966 set id [open $cache "w"] 967 puts -nonewline $id "$sum" 968 close $id 969 } else { 970 remote_exec build cp "$prog $cache" 971 } 972 set id [open "${cache}.res" "w"] 973 puts $id [lindex $result 0] 974 puts -nonewline $id [lindex $result 1] 975 close $id 976 } 977 } 978 } 979 } 980 return $result 981} 982 983proc remote_raw_load { dest prog args } { 984 return [eval call_remote raw load \"$dest\" \"$prog\" $args ] 985} 986 987# 988# The default load procedure if no other exists for $dest. It uses 989# remote_download and remote_exec to load and execute the program. 990# 991 992proc standard_load { dest prog args } { 993 if { [llength $args] > 0 } { 994 set pargs [lindex $args 0] 995 } else { 996 set pargs "" 997 } 998 999 if { [llength $args] > 1 } { 1000 set inp "[lindex $args 1]" 1001 } else { 1002 set inp "" 1003 } 1004 1005 if ![file exists $prog] then { 1006 # We call both here because this should never happen. 1007 perror "$prog does not exist in standard_load." 1008 verbose -log "$prog does not exist." 3 1009 return "untested" 1010 } 1011 1012 if [is_remote $dest] { 1013 set remotefile "/tmp/[file tail $prog].[pid]" 1014 set remotefile [remote_download $dest $prog $remotefile] 1015 if { $remotefile == "" } { 1016 verbose -log "Download of $prog to [board_info $dest name] failed." 3 1017 return "unresolved" 1018 } 1019 if [board_info $dest exists remote_link] { 1020 if [[board_info $dest remote_link] $remotefile] { 1021 verbose -log "Couldn't do remote link" 1022 remote_file target delete $remotefile 1023 return "unresolved" 1024 } 1025 } 1026 set status [remote_exec $dest $remotefile $pargs $inp] 1027 remote_file $dest delete $remotefile 1028 } else { 1029 set status [remote_exec $dest $prog $pargs $inp] 1030 } 1031 if { [lindex $status 0] < 0 } { 1032 verbose -log "Couldn't execute $prog, [lindex $status 1]" 3 1033 return "unresolved" 1034 } 1035 set output [lindex $status 1] 1036 set status [lindex $status 0] 1037 1038 verbose -log "Executed $prog, status $status" 2 1039 if ![string match "" $output] { 1040 verbose -log -- "$output" 2 1041 } 1042 if { $status == 0 } { 1043 return [list "pass" $output] 1044 } else { 1045 return [list "fail" $output] 1046 } 1047} 1048 1049# 1050# Loads PROG into DEST. 1051# 1052proc remote_ld { dest prog } { 1053 return [eval call_remote \"\" ld \"$dest\" \"$prog\"] 1054} 1055 1056proc remote_raw_ld { dest prog } { 1057 return [eval call_remote raw ld \"$dest\" \"$prog\"] 1058} 1059 1060# Wait up to TIMEOUT seconds for the last spawned command on DEST to 1061# complete. A list of two values is returned; the first is the exit 1062# status (-1 if the program timed out), and the second is any output 1063# produced by the command. 1064 1065proc remote_wait { dest timeout } { 1066 return [eval call_remote \"\" wait \"$dest\" $timeout] 1067} 1068 1069proc remote_raw_wait { dest timeout } { 1070 return [eval call_remote raw wait \"$dest\" $timeout] 1071} 1072 1073# The standard wait procedure, used for commands spawned on the local 1074# machine. 1075proc standard_wait { dest timeout } { 1076 set output "" 1077 set status -1 1078 1079 if [info exists exp_close_result] { 1080 unset exp_close_result 1081 } 1082 remote_expect $dest $timeout { 1083 -re ".+" { 1084 append output $expect_out(buffer) 1085 if { [string length $output] > 512000 } { 1086 remote_close $dest 1087 set status 1 1088 } else { 1089 exp_continue -continue_timer 1090 } 1091 } 1092 timeout { 1093 warning "program timed out." 1094 } 1095 eof { 1096 if [board_info $dest exists fileid_origid] { 1097 global board_info 1098 1099 set id [board_info $dest fileid] 1100 set oid [board_info $dest fileid_origid] 1101 verbose "$id $oid" 1102 unset board_info($dest,fileid) 1103 unset board_info($dest,fileid_origid) 1104 catch "close -i $id" 1105 # I don't believe this. You HAVE to do a wait, even tho 1106 # it won't work! stupid ()*$%*)(% expect... 1107 catch "wait -i $id" 1108 set r2 [catch "close $oid" res] 1109 if { $r2 != 0 } { 1110 verbose "close result is $res" 1111 set status 1 1112 } else { 1113 set status 0 1114 } 1115 } else { 1116 set s [wait -i [board_info $dest fileid]] 1117 if { [lindex $s 0] != 0 && [lindex $s 2] == 0 } { 1118 set status [lindex $s 3] 1119 if { [llength $s] > 4 } { 1120 if { [lindex $s 4] == "CHILDKILLED" } { 1121 set status 1 1122 } 1123 } 1124 } 1125 } 1126 } 1127 } 1128 1129 remote_close $dest 1130 return [list $status $output] 1131} 1132 1133# This checks the value cotained in the variable named "variable" in 1134# the calling procedure for output from the status wrapper and returns 1135# a non-negative value if it exists; otherwise, it returns -1. The 1136# output from the wrapper is removed from the variable. 1137 1138proc check_for_board_status { variable } { 1139 upvar $variable output 1140 1141 # If all programs of this board have a wrapper that always outputs a 1142 # status message, then the absence of it means that the program 1143 # crashed, regardless of status found elsewhere (e.g. simulator exit 1144 # code). 1145 if { [target_info needs_status_wrapper] != "" } then { 1146 set nomatch_return 2 1147 } else { 1148 set nomatch_return -1 1149 } 1150 1151 if [regexp "(^|\[\r\n\])\\*\\*\\* EXIT code" $output] { 1152 regsub "^.*\\*\\*\\* EXIT code " $output "" result 1153 regsub "\[\r\n\].*$" $result "" result 1154 regsub -all "(^|\[\r\n\]|\r\n)\\*\\*\\* EXIT code \[^\r\n\]*(\[\r\n\]\[\r\n\]?|$)" $output "" output 1155 regsub "^\[^0-9\]*" $result "" result 1156 regsub "\[^0-9\]*$" $result "" result 1157 verbose "got board status $result" 3 1158 verbose "output is $output" 3 1159 if { $result == "" } { 1160 return $nomatch_return 1161 } else { 1162 return [expr $result] 1163 } 1164 } else { 1165 return $nomatch_return 1166 } 1167} 1168 1169# 1170# remote_expect works basically the same as standard expect, but it 1171# also takes care of getting the file descriptor from the specified 1172# host and also calling the timeout/eof/default section if there is an 1173# error on the expect call. 1174# 1175 1176proc remote_expect { board timeout args } { 1177 global errorInfo errorCode 1178 global remote_suppress_flag 1179 1180 set spawn_id [board_info $board fileid] 1181 1182 if { [llength $args] == 1 } { 1183 set args "[lindex $args 0]" 1184 } 1185 1186 set res {} 1187 set got_re 0 1188 set need_append 1 1189 1190 set orig "$args" 1191 1192 set error_sect "" 1193 set save_next 0 1194 1195 if { $spawn_id == "" } { 1196 # This should be an invalid spawn id. 1197 set spawn_id 1000 1198 } 1199 1200 for { set i 0 } { $i < [llength $args] } { incr i } { 1201 if { $need_append } { 1202 append res "\n-i $spawn_id " 1203 set need_append 0 1204 } 1205 1206 set x "[lrange $args $i $i]" 1207 regsub "^\n*\[ \]*" "$x" "" x 1208 1209 if { $x == "-i" || $x == "-timeout" || $x == "-ex" } { 1210 append res "$x " 1211 set next [expr ${i}+1] 1212 append res "[lrange $args $next $next]" 1213 incr i 1214 continue 1215 } 1216 if { $x == "-n" || $x == "-notransfer" || $x == "-nocase" || $x == "-indices" } { 1217 append res "${x} " 1218 continue 1219 } 1220 if { $x == "-re" } { 1221 append res "${x} " 1222 set next [expr ${i}+1] 1223 set y [lrange $args $next $next] 1224 append res "${y} " 1225 set got_re 1 1226 incr i 1227 continue 1228 } 1229 if { $got_re } { 1230 set need_append 0 1231 append res "$x " 1232 set got_re 0 1233 if { $save_next } { 1234 set save_next 0 1235 set error_sect [lindex $args $i] 1236 } 1237 } else { 1238 if { ${x} == "eof" } { 1239 set save_next 1 1240 } elseif { ${x} == "default" || ${x} == "timeout" } { 1241 if { $error_sect == "" } { 1242 set save_next 1 1243 } 1244 } 1245 append res "${x} " 1246 set got_re 1 1247 } 1248 } 1249 1250 if [info exists remote_suppress_flag] { 1251 if { $remote_suppress_flag } { 1252 set code 1 1253 } 1254 } 1255 if ![info exists code] { 1256 set res "\n-timeout $timeout $res" 1257 set body "expect \{\n-i $spawn_id -timeout $timeout $orig\}" 1258 set code [catch {uplevel $body} string] 1259 } 1260 1261 if {$code == 1} { 1262 if { $error_sect != "" } { 1263 set code [catch {uplevel $error_sect} string] 1264 } else { 1265 warning "remote_expect statement without a default case?!" 1266 return 1267 } 1268 } 1269 1270 if {$code == 1} { 1271 return -code error -errorinfo $errorInfo -errorcode $errorCode $string 1272 } elseif {$code == 2} { 1273 return -code return $string 1274 } elseif {$code == 3} { 1275 return 1276 } elseif {$code > 4} { 1277 return -code $code $string 1278 } 1279} 1280 1281# Push the current connection to HOST onto a stack. 1282proc remote_push_conn { host } { 1283 global board_info 1284 1285 set name [board_info $host name] 1286 1287 if { $name == "" } { 1288 return "fail" 1289 } 1290 1291 if ![board_info $host exists fileid] { 1292 return "fail" 1293 } 1294 1295 set fileid [board_info $host fileid] 1296 set conninfo [board_info $host conninfo] 1297 if ![info exists board_info($name,fileid_stack)] { 1298 set board_info($name,fileid_stack) {} 1299 } 1300 set board_info($name,fileid_stack) [list $fileid $conninfo $board_info($name,fileid_stack)] 1301 unset board_info($name,fileid) 1302 if [info exists board_info($name,conninfo)] { 1303 unset board_info($name,conninfo) 1304 } 1305 return "pass" 1306} 1307 1308# Pop a previously-pushed connection from a stack. You should have closed the 1309# current connection before doing this. 1310proc remote_pop_conn { host } { 1311 global board_info 1312 1313 set name [board_info $host name] 1314 1315 if { $name == "" } { 1316 return "fail" 1317 } 1318 if ![info exists board_info($name,fileid_stack)] { 1319 return "fail" 1320 } 1321 set stack $board_info($name,fileid_stack) 1322 if { [llength $stack] < 3 } { 1323 return "fail" 1324 } 1325 set board_info($name,fileid) [lindex $stack 0] 1326 set board_info($name,conninfo) [lindex $stack 1] 1327 set board_info($name,fileid_stack) [lindex $stack 2] 1328 return "pass" 1329} 1330 1331# 1332# Swap the current connection with the topmost one on the stack. 1333# 1334proc remote_swap_conn { host } { 1335 global board_info 1336 set name [board_info $host name] 1337 1338 if ![info exists board_info($name,fileid)] { 1339 return "fail" 1340 } 1341 1342 set fileid $board_info($name,fileid) 1343 if [info exists board_info($name,conninfo)] { 1344 set conninfo $board_info($name,conninfo) 1345 } else { 1346 set conninfo {} 1347 } 1348 if { [remote_pop_conn $host] != "pass" } { 1349 set board_info($name,fileid) $fileid 1350 set board_info($name,conninfo) $conninfo 1351 return "fail" 1352 } 1353 set newfileid $board_info($name,fileid) 1354 set newconninfo $board_info($name,conninfo) 1355 set board_info($name,fileid) $fileid 1356 set board_info($name,conninfo) $conninfo 1357 remote_push_conn $host 1358 set board_info($name,fileid) $newfileid 1359 set board_info($name,conninfo) $newconninfo 1360 return "pass" 1361} 1362 1363set sum_program "testcsum" 1364