contrib/bluegnu2.0.3/lib/remote.exp

# Copyright (C) 92, 93, 94, 95, 1996 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@welcomehome.org)

# these just need to be initialized
# FIXME: This is deprecated (we should have no knowledge of global `shell_id').
# Remove at some point.
set shell_id   	0

# 
# Open a connection to a remote host or target. This requires the target_info
# array be filled in with the proper info to work. The old variables are also
# still functional.
#
# type is either "host" or "target". The default is target if no type is supplied.
# It returns the spawn id of the process that is the connection.
#	
proc remote_open { args } {
    global target_info
    global connectmode
    global targetname
    global serialport
    global netport
    global reboot
    global shell_id
    global spawn_id
   
    if { [llength $args] == 0 } {
	set type "target"
    } else {
	set type $args
    }

    # set the current connection
    if [info exists target_info(${type},name)] {	
	if { $target_info(${type},name) != "" } {	
	    if { [info proc push_$type] != "" } {
		push_$type $target_info(${type},name)
	    }
	} else {
	    warning "Couldn't push target, name was NULL"
	}
    }

    if [info exists target_info(${type},connect)] {
	set connect_prog $target_info(${type},connect)
    } else {
	if [info exists connectmode] {
	    set connect_prog $connectmode
	} else {
	    perror "No connectmode specified"
	    set shell_id -1
	    return $shell_id
	}
    }

    # reboot the machine if we neeed to, typically by using an x10 controller.
    if $reboot {
	if { [info procs "reboot_hook"] != "" } {
	    reboot_hook
	}
    }

    set shell_id [$connect_prog $type]

    if [info exists target_info] {
	set target_info(${type},fileid) $shell_id
	if [info exists target_info(${type},name)] {
	    set target_info($target_info(${type},name),fileid) $shell_id
	}
    }
    return $shell_id
}

#
# Close the remote connection.
#	shell_id - This is the id number returned by the any of the connection
#	procedures, or an index into one of the arrays. 
#
proc remote_close { arg } {
    # get the type of connection, host or target
    if [expr [string match "host" $arg] || [string match "target" $arg]] {
	set type $arg
	if [info exists target_info(${type},fileid)] {
	    set shell_id $target_info(${type},fileid)
	} else {
	    perror "No shell id for to close"
	}
    } else {
	set shell_id $arg
    }

    verbose "Closing the remote shell $shell_id" 2
    catch "close -i $shell_id"
    catch "wait -i $shell_id"

    return 0
}


# Most of these procedures try to establish the connection 3 times before
# returning. If $verbose is set to a value of 2 or greater, then error
# messages will appear for each attempt. If there is an error that
# can't be recovered from, it returns a -1. If the connection is
# established, it returns the shell's process number returned by the
# tcl command spawn.
# Hostname refers to the entry in /etc/hosts for this target. The
# procedure's name is the same as its unix counterpart.
# The final argument is the type of connection to establish, the default
# is the target. This can also be passed as the second arg or the third.

#
# Connect using telnet. This takes two arguments. The first one is the
# hostname, and the second is the optional port number. This sets
# the fileid field in the config array, and returns -1 for error, or the
# spawn id.
#
proc telnet { args } {
    global verbose
    global connectmode
    global shell_prompt
    global spawn_id
    global timeout
    global errno

    set hostname [lindex $args 0]
    
    # get the port number
    if { [llength $args] > 1 } {
	set port [lindex $args 1]
    } else {
        set port 23
    }
    
    # get the hostname and port number from the config array
    if [expr [string match "host" $hostname] || [string match "target" $hostname]] {
	set type $hostname
	set hosttmp [split $target_info($type,netport) ":"]
	set hostname [lindex $hosttmp 0]
	if { [llength $hosttmp] > 1 } {
	    set port [lindex $hosttmp 1]
	}
	unset hosttmp
	if [info exists target_info($type,prompt)] {
	    set shell_prompt $target_info($type,prompt)
	}
    } else {
	set type target
    }
    if ![info exists shell_prompt] {	# if no prompt, then set it to something generic
	set shell_prompt ".*> "
    }
 
    set tries 0
    set result -1
    verbose "Starting a telnet connection to $hostname:$port" 2
    spawn telnet $hostname $port
    exp_send "\r\n"
    while { $tries <= 3 } {
	catch expect {
	    "ogin:" {
		perror "telnet: need to login"
		break
	    }
	    "assword:" {
		perror "telnet: need a password"
		break
	    }
	    -re ".*$shell_prompt.*$" {
		verbose "Got prompt\n"
		set result 0
	    }
	    "Connected to" {
		exp_continue
	    }
	    -re "\[\r\n\]*" {
		exp_continue
	    }
	    "unknown host" {
		exp_send "\003"
		perror "telnet: unknown host"
		break
	    }
	    "Escape character is" {
		exp_send "\r\n"
		exp_continue
	    }
	    "has logged on from" {
		exp_continue
	    }
	    "You have no Kerberos tickets" {
		warning "telnet: no kerberos Tickets, please kinit"
		break
	    }
	    -re "Connection refused.*$" {
		exp_send "\003"
		warning "telnet: connection refused."
	    }
	    -re "Sorry, this system is engaged.*" {
		exp_send "\003"
		warning "telnet: already connected."
	    }
	    "Connection closed by foreign host.*$" {
		warning "telnet: connection closed by foreign host."
		break
	    }
	    timeout { 
		exp_send "\003"
		warning "telnet: timed out trying to connect."
	    }
	    eof {
		perror "telnet: got unexpected EOF from telnet."
		break
	    }
	}
	incr tries
    }
    # we look for this hear again cause it means something went wrong, and
    # it doesn't always show up in the expect in buffer till the server times out.
    if [info exists expect_out(buffer)] {
	if [regexp "assword:|ogin:|" $expect_out(buffer)] {
	    perror "telnet: need to supply a login and password."
	}
    }
    if { $result < 0 } {
	catch close
	catch wait
#	perror "telnet: couldn't connect after $tries tries."
	set spawn_id -1
    }
    set target_info(target,fileid) $spawn_id
    if [info exists target_info(target,name)] {
	set target_info($target_info(target,name),fileid) $spawn_id
    }
    return $spawn_id
}

#
# Connect to hostname using rlogin. The global RLOGIN
# is the name of the actual rlogin program. This is for systems
# using rlogin to braindead targets that don't support kerboros.
# It returns either the spawn_id or a -1.
# The final argument is the type of connection to establish, the default
# is the target. This can also be passed as the second arg or the third.
#
proc rlogin { arg } {
    global spawn_id
    global target_info
    global RLOGIN
    global errno

    set tries 0
    set result -1

    # get the hostname and port number from the config array
    if [expr [string match "host" $arg] || [string match "target" $arg]] {
	set type $arg
	set hostname [lindex [split $target_info(${type},netport) ":"] 0]
	if [info exists target_info($type,prompt)] {
	    set shell_prompt $target_info($type,prompt)
	}
    } else {
	set hostname $arg
	set type target
    }
    if ![info exists shell_prompt] {	# if no prompt, then set it to something generic
	set shell_prompt ".*> "
    }
 
    # get the right version of rlogin
    if ![info exists RLOGIN] {
	set RLOGIN rlogin
    }
    
    # start connection and store the spawn_id
    verbose "Opening a $RLOGIN connection to $hostname" 2
    spawn $RLOGIN $hostname
    if { $spawn_id < 0 } {
	perror "invalid spawn id from rlogin"
	return
    }
    set target_info(${type},fileid) $spawn_id
    if [info exists target_info($type,name)] {
	set target_info($target_info($type,name),fileid) $spawn_id
    }
    
    # try to connect to the target. We give up after 3 attempts. At one point
    # we used to look for the prompt, but we may not know what it looks like.
    while { $tries <= 3 } {
	expect {
	    -re ".*$shell_prompt.*$" {
		verbose "Got prompt\n"
		set result 0
		break
	    }
	    -re "TERM = .*\\)\[ ]*$" {
		send "dumb\r\n"
		expect {
		    "Terminal type is*$" {
			verbose "rlogin: set the terminal to dumb" 2
		    }
		    default {
			warning "rlogin: couldn't set terminmal type"
		    }
		}
		set result 10
		break
	    }
	    "unknown host" {
		perror "rlogin: unknown host"
		break
	    }
	    "has logged on from" {
		exp_continue
	    }
	    "Terminal type is" {
		verbose "rlogin: connected, got terminal prompt" 2
		set result 0
		break
	    }
	    -re "Maximum number of users already logged in.*$" {
		warning "rlogin: maximum number of users already logged in"
	    }
	    -re "Sorry, shell is locked.*Connection closed.*$" {
		warning "rlogin: lready connected."
	    }
	    -re "Sorry, this system is engaged.*Connection closed.*$" {
		warning "rlogin: system engaged."
	    }
	    -re "Kerberos rcmd failed.*$" {
		warning "rlogin: Kerberos rcmd failed, please kinit"
		catch close
		catch wait
       		break
	    }
	    -re "trying normal rlogin.*$" {
		warning "rlogin: trying normal rlogin."
		catch close
		catch wait
		break
	    }
	    -re "unencrypted connection.*$" {
		warning "rlogin: unencrypted connection, please kinit"
		catch close
		catch wait
		break
	    }
	    -re "isn't registered for Kerberos.*service.*$" {
		warning "rsh: isn't registered, please kinit"
		catch close
		catch wait
		break
	    }
	    -re "You have no Kerberos tickets.*$" {
		warning "rlogin: No kerberos Tickets, please kinit"
		catch close
		catch wait
		break
	    }
	    timeout	{ 
		warning "rlogin: timed out trying to connect."
	    }
	    eof {
		perror "rlogin: got EOF while trying to connect."
		break
	    }
	}
	incr tries
    }

    # if the error was fatal, there's nothing to send to
    catch { send "\r\n" } tmp
    if [string match "*invalid spawn id*" $tmp] {
	perror "Couldn't rlogin to $hostname, fatal error."
	catch "close $spawn_id"
	set target_info(${type},fileid) $spawn_id
	if [info exists target_info(${type},name)] {
	    set target_info($target_info(${type},name),fileid) $spawn_id
	}
	return $spawn_id
    }
    expect {
	"\r\n*$" {
	    exp_continue
	}
	-re "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]+.*$" {
	    # this is kinda gross, but if we get most any legit ascii
	    # text we figure we connected. Others tests later will
	    # determine if the connection actually works.
	    verbose "We got some text" 2
	}
    }

    # see if we maxed out on errors
    if { $result < 0 } {
	catch close
	catch wait
#	perror "rlogin: couldn't rlogin to $hostname, Too many errors"
	catch "close $spawn_id"
	set spawn_id -1
	set target_info(${type},fileid) $spawn_id
	if [info exists target_info(${type},name)] {
	    set target_info($target_info(${type},name),fileid) $spawn_id
	}
    } else {
	verbose "rlogin: connected to $hostname" 2
    }
    
    return $spawn_id
}

#
# Connect to hostname using rsh
#
proc rsh { arg } {
    global spawn_id
    global target_info
    global RSH
    global errno

    set tries 0
    set result -1

    # get the hostname and port number from the config array
    if [expr [string match "host" $arg] || [string match "target" $arg]] {
	set type $arg
	set hostname [lindex [split $target_info(${type},netport) ":"] 0]
	if [info exists target_info(${type},prompt)] {
	    set shell_prompt $target_info(${type},prompt)
	}
    } else {
	set hostname $arg
	set type target
    }
    if ![info exists shell_prompt] {	# if no prompt, then set it to something generic
	set shell_prompt ".*> "
    }
 
    if ![info exists RSH] {
	set RSH rsh
    }
    spawn $RSH $hostname
    if { $spawn_id < 0 } {
	perror "invalid spawn id from rsh"
	return
    }
    set target_info(${type},fileid) $spawn_id
    if [info exists target_info(${type},name)] {
	set target_info($target_info(${type},name),fileid) $spawn_id
    }
    if [info exists target_info(${type},prompt)] {
	set prompt $target_info(${type},prompt)
    }
    send "\r\n"
    while { $tries <= 3 } {
	expect {
	    -re ".*$shell_prompt.*$" {
		verbose "Got prompt\n"
		set result 0
		break
	    }
	    -re "TERM = .*$" {
		warning "Setting terminal type to vt100"
		set result 0
		send "vt100\n"
		break
	    }
	    "unknown host" {
		exp_send "\003"
		perror "telnet: unknown host"
		break
	    }
	    "has logged on from" {
		exp_continue
	    }
	    -re "isn't registered for Kerberos.*service.*$" {
		warning "rsh: isn't registered for Kerberos, please kinit"
		catch close
		catch wait
		break
	    }
	    -re "Kerberos rcmd failed.*$" {
		warning "rsh: Kerberos rcmd failed, please kinit"
		catch close
		catch wait
		break
	    }
	    -re "You have no Kerberos tickets.*$" {
		warning "rsh: No kerberos Tickets, please kinit"
		catch close
		catch wait
		break
	    }
	    "Terminal type is" {
		verbose "rsh: connected, got terminal prompt" 2
		set result 0
		break
	    }
	    -re "trying normal rlogin.*$" {
		warning "rsh: trying normal rlogin."
		catch close
		catch wait
		break
	    }
	    -re "unencrypted connection.*$" {
		warning "rsh: unencrypted connection, please kinit"
		catch close
		catch wait
		break
	    }
	    -re "Sorry, shell is locked.*Connection closed.*$" {
		warning "rsh: already connected."
	    }
	    timeout {	    
	       warning "rsh: timed out trying to connect."
	    }
	    eof {	    
		perror "rsh: got EOF while trying to connect."
		break
	    }
	}
	incr tries
    }
    
    if { $result < 0 } {
#	perror "rsh: couldn't connect after $tries tries."
	set spawn_id -1
    }
    set target_info(${type},fileid) $spawn_id
    if [info exists target_info(${type},name)] {
	set target_info($target_info(${type},name),fileid) $spawn_id
    }
    return $spawn_id
}

#
# Download an executable to a network neighbor
#
# DEST is assumed to already contain the nodename.
# Returns the status returned by the rcp command.
#
proc rcp_download { src dest } {
    set status [catch "exec rcp $src $dest" output]
    if { $status == 0 } {
	verbose "Copied $src to $dest" 2
    } else {
	verbose "Download to $dest failed, $output."
    }
    return $status
}

#
# This proc is deprecated.  Please use `execute_anywhere' instead.
#
# Execute a program on the remote system using rsh
#
# SYSTEM is the host name of the system to run the program on.
# CMD is the program to run (including path) and any arguments.
# The result is a list of two elements.
# First element: 0 for success, 1 for failure, -1 for comms failure.
# Second element: program output (success/failure) or error message (comms).
#
proc rsh_exec { system cmd } {
    verbose "Executing $system:$cmd" 3
    # If CMD sends any output to stderr, exec will think it failed.  More often
    # than not that will be true, but it doesn't catch the case where there is
    # no output but the exit code is non-zero.  The "2>&1" is done on the
    # remote system and is not a special flag for `exec'.
    set status [catch "exec rsh $system $cmd 2>&1 \\; echo XYZ$?ZYX" output]
    # `status' doesn't mean much here other than rsh worked ok.
    # What we want is whether $cmd ran ok.
    if { $status != 0 } {
	regsub "XYZ(\[0-9\]*)ZYX\n?" $output "" output
	return [list -1 "rsh to $system failed for $cmd, $output"]
    }
    regexp "XYZ(\[0-9\]*)ZYX" $output junk status
    verbose "rsh_exec: status:$status text:$output" 4
    if { $status == "" } {
	return [list -1 "Couldn't parse rsh output, $output."]
    }
    regsub "XYZ(\[0-9\]*)ZYX\n?" $output "" output
    # Delete one trailing \n because that is what `exec' will do and we want
    # to behave identical to it.
    regsub "\n$" $output "" output
    return [list [expr $status != 0] $output]
}

#
# Connect to using tip
# port - must be a name from /etc/remote, or "host" or "target".
# returns -1 if it failed, the spawn_id if it worked
#
proc tip { arg } {
    global verbose
    global shell_prompt
    global target_info
    global spawn_id

    set tries 0
    set result -1

    if [expr [string match "host" $arg] || [string match "target" $arg]] {
	set port $target_info(${type},target)
	if [info exists target_info(${type},prompt)] {
	    set shell_prompt $target_info(${type},prompt)
	}
    } else {
	set port $arg
    }
    if ![info exists shell_prompt] {	# if no prompt, then set it to something generic
	set shell_prompt ".*> "
    }
 
    spawn tip -v $port
    if { $spawn_id < 0 } {
	perror "invalid spawn id from tip"
	return -1
    }
    set target_info(target,fileid) $spawn_id
    set target_info($target_info(target,name),fileid) $spawn_id
    expect {
	-re ".*connected.*$" { 
	    send "\r\n"
	    expect {
		-re ".*$shell_prompt.*$" {
		    verbose "Got prompt\n"
		    set result 0
		    incr tries
		}
		timeout {
		    warning "Never got prompt."
		    set result -1
		    incr tries
		    if $tries<=2 {
			exp_continue
		    }
		}
	    }
	}
	-re "all ports busy.*$" {
	    set result -1
	    perror "All ports busy."
	    incr tries
	    if { $tries <= 2 } {
		exp_continue
	    }	    
	}
	-re "Connection Closed.*$" {
	    perror "Never connected."
	    set result -1
	    incr tries
	    if { $tries <= 2 } {
		exp_continue
	    }
	}
	-re ".*: Permission denied.*link down.*$" {
	    perror "Link down."
	    set result -1
	    incr tries
	}
	timeout	{
	    perror "Timed out trying to connect."
	    set result -1
	    incr tries
	    if { $tries <= 2 } {
		exp_continue
	    }
	}
	eof {
	    perror "Got unexpected EOF from tip."
	    set result -1
	    incr tries
	}
    }

    send "\n~s"
    expect {
	"~\[set\]*" {
	    verbose "Setting verbose mode" 1
	    send "verbose\n\n\n"
	}	
    }

    if { $result < 0 } {
	perror "Couldn't connect after $tries tries."
	set target_info(${type},fileid) -1
	set target_info($target_info(${type},name),fileid) -1
	return -1
    } else {
	set target_info(${type},fileid) $spawn_id
	set target_info($target_info(${type},name),fileid) $spawn_id
	return $spawn_id
    }
}

#
# Downloads using the ~put command under tip
#     arg - is a full path name to the file to download
#     returns 1 if an error occured, otherwise it returns
#	  the spawn_id.
#
proc tip_download { shell_id file } {
    global verbose
    global decimal
    global shell_prompt
    global expect_out

    set result 1
    if ![file exists $file] {
	perror "$file doesn't exist."
	return 1
    }

    send -i $shell_id "\n~p"
    expect {
	-i $shell_id "~\[put\]*" {
	    verbose "Downloading $file, please wait" 1
	    send -i $shell_id "$file\n"
	    set timeout 50
	    expect {
		-i $shell_id -re ".*$file.*$" {
		    exp_continue
		}
		-i $shell_id -re ".*lines transferred in.*minute.*seconds.*$shell_prompt.*$" {
		    verbose "Download $file successfully" 1
		    set result 0
		}
		-i $shell_id -re ".*Invalid command.*$shell_prompt$" {
		    warning "Got an Invalid command to the monitor"
		}
		-i $shell_id -re ".*$decimal\r" {
		    if [info exists expect_out(buffer)] {
			verbose "$expect_out(buffer)"
			exp_continue
		    }
		}
		-i $shell_id timeout {
		    perror "Timed out trying to download."
		    set result 1
		}
	    }
	}	
	timeout {
	    perror "Timed out waiting for response to put command."
	}
    }	
    set timeout 10
    return $result
}

#
# Connect to using kermit
#     args - first is the device name, ie. /dev/ttyb
#         second is the optional baud rate. If this is "host" or "target" the 
#	  config array is used instead.
#     returns -1 if it failed, otherwise it returns
#         the spawn_id.
#
proc kermit { args } {
    global verbose
    global shell_prompt
    global spawn_id

    if { [llength $args] == 1 } {
	set baud 9600
    } else {
	set baud [lindex $args 1]
    } 

    if [expr [string match "host" [lindex $args 0]] || [string match "target" [lindex $arg 0]]] {
	set device $target_info(${type},serial)
	if [info exists target_info(${type},baud)] {
	    set baud $target_info(${type},baud)
	}
    } else {
	set device [lindex $args 0]
    }
 
    set tries 0
    set result -1
    spawn kermit -l $device -b $baud
    if { $spawn_id < 0 } {
	perror "invalid spawn id from kermit"
	return -1
    }
    set target_info(${type},fileid) $spawn_id
    set target_info($target_info(${type},name),fileid) $spawn_id
    expect {
	-re ".*ermit.*>.*$" { 
	    send "c\n"
	    expect {
		-re ".*Connecting to $port.*Type the escape character followed by C to.*$" {
		    verbose "Got prompt\n"
		    set result 0
		    incr tries
		}
		timeout {
		    warning "Never got prompt."
		    set result -1
		    incr tries
		    if { $tries <= 2 } {
			exp_continue
		    }
		}
	    }
	}
	-re "Connection Closed.*$" {
	    perror "Never connected."
	    set result -1
	    incr tries
	    if { $tries <= 2 } {
		exp_continue
	    }
	}
	timeout			{	    
	    warning "Timed out trying to connect."
	    set result -1
	    incr tries
	    if { $tries<=2 } {
		exp_continue
	    }
	}
    }

    if { $result < 0 } {
	perror "Couldn't connect after $tries tries."
	set target_info(${type},fileid) -1
	set target_info($target_info(${type},name),fileid) -1
	return -1
    } else {
	set target_info(${type},fileid) $spawn_id
	set target_info($target_info(${type},name),fileid) $spawn_id
	return $spawn_id
    }
}

#
# exit the remote shell
#
# ??? This proc is deprecated.  Please use `remote_close' instead.
proc exit_remote_shell { shell_id } {
    return [remote_close $shell_id]
}

#
# Download a file using stdin. This will download a file
# regardless of whether rlogin, telnet, tip, or kermit was
# used to establish the connection.
#
proc download { args } {
    global spawn_id
    global verbose

    set file [lindex $args 0]

    if { [llength $args] > 1 } {
        set shellid [lindex $args 1]
    } else {
        set shellid $spawn_id
    }

    set lines 0
    set fd [open $file r]
    while { [gets $fd cur_line] >= 0 } {
        set errmess ""
        catch "send -i $shellid \"$cur_line\"" errmess
        if [string match "write\(spawn_id=\[0-9\]+\):" $errmess] {
            perror "sent \"$command\" got expect error \"$errmess\""
            catch "close $fd"
            return -1
        }
        verbose "." 2
        verbose "Sent $cur_line" 3
	incr lines
    }
    verbose "$lines lines downloaded"
    close $fd
    return 0
}