contrib/bluegnu2.0.3/lib/target.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)

# a hairy pattern to recognize text
set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]"

#
# this is a collection of support procs for the target data
# structures. We use a named array, since Tcl has no real data
# structures. Here's the special index words for the array:
#       Required fields are:
#	    name    - the name of the target. (mostly for error messages) This
#		      should also be the string used for this target's array.
#                     It should also be the same as the linker script so we
#		      can find them dynamically.
#       Optional fields are:
#	    ldflags - the flags required to produce a fully linked executable.
#	    config  - the target canonical for this target. This is a regexp
#		      as passed to istarget or isnative.
#	    cflags  - the flags required to produce an object file from a
#		      source file.
#	    connect - the connectmode for this target. This is for both IP and
#		      serial connections.
#	    target  - the hostname of the target. This is for TCP/IP based connections,
#		      and is also used for version of tip that use /etc/remote.
#	    serial  - the serial port. This is typically /dev/tty? or com?:.
#	    netport - the IP port.
#	    baud    - the baud rate for a serial port connection.
#	    x10     - parameters for the x10 controller (used to reboot)
#	    fileid  - the fileid or spawn id of of the connection.
#	    prompt  - a regexp for matching the prompt.
#	    abbrev  - abbreviation for tool init files.
#	    ioport  - the port for I/O on dual port systems.
#
# there are three main arrays, indexed in with "target", "build", and "host".
# all other targets are indexed with a name usually based on the linker script
# like "idp", or "ex93x.ld".
#

#
# Set the elements of the target data structure
# The order of the values is name, ldflags, config, cflags, connect, target, serial,
# netport, baud, x10, fileid, prompt, abbrev, ioport.
# FIXME: I'm not entirely sure this proc is a good idea...
proc set_target_info { args } {
    global target_info

    set name [lindex $args 0]

    # process the linker arguments
    if { [llength $args] > 0 } {
	set target_info($name,ldflags) [lindex $args 1]
    } else {
	set target_info($name,ldflags) ""
    }

    # process the config string
    if { [llength $args] > 1 } {
	set target_info($name,config) [lindex $args 2]
    } else {
	set target_info($name,config) ""
    }

    # process the compiler arguments
    if { [llength $args] > 2 } {
	set target_info($name,cflags) [lindex $args 3]
    } else {
	set target_info($name,cflags) ""
    }

    # process the connection mode
    if { [llength $args] > 3 } {
	set target_info($name,connect) [lindex $args 3]
    } else {
	set target_info($name,connect) ""
    }

    # process the target's hostname
    if { [llength $args] > 4 } {
	set target_info($name,target) [lindex $args 3]
    } else {
	set target_info($name,target) ""
    }

    # process the serial port
    if { [llength $args] > 5 } {
	set target_info($name,serial) [lindex $args 3]
    } else {
	set target_info($name,serial) ""
    }

    # process the netport
    if { [llength $args] > 6 } {
	set target_info($name,netport) [lindex $args 3]
    } else {
	set target_info($name,netport) ""
    }

    # process the baud
    if { [llength $args] > 7 } {
	set target_info($name,baud) [lindex $args 3]
    } else {
	set target_info($name,baud) ""
    }

    # process the x10 unit number.
    if { [llength $args] > 8 } {
	set target_info($name,x10) [lindex $args 3]
    } else {
	set target_info($name,x10) ""
    }

    # process the fileid
    if { [llength $args] > 9 } {
	set target_info($name,fileid) [lindex $args 3]
    } else {
	set target_info($name,fileid) ""
    }

    # process the prompt
    if { [llength $args] > 10 } {
	set target_info($name,prompt) [lindex $args 3]
    } else {
	set target_info($name,prompt) ""
    }

    # process the abbrev
    if { [llength $args] > 10 } {
	set target_info($name,connect) [lindex $args 3]
    } else {
	set target_info($name,connect) ""
    }

    # process the ioport
	 if { [llength $args] > 11 } {
	set target_info($name,ioport) [lindex $args 3]
    } else {
	set target_info($name,ioport) ""
    }
}

#
# Set the target connection.
#
proc push_target { name } {
    pop_config  target
    push_config target $name
}

#
# Set the host connnection.
#
proc push_host { name } {
    pop_config host
    push_config host $name
}

#
# Set the config for the current host or target connection.
#
proc push_config { type name } {
    global target_info

    if [info exists target_info(${name},name)] {
	set target_info($type,name)    $name
    }
    if [info exists target_info(${name},ldflags)] {
	set target_info($type,ldflags) $target_info(${name},ldflags)
    }
    if [info exists target_info(${name},config)] {
	set target_info($type,config)  $target_info(${name},config)
    }
    if [info exists target_info(${name},cflags)] {
	set target_info($type,cflags)  $target_info(${name},cflags)
    }
    if [info exists target_info(${name},connect)] {
	set target_info($type,connect) $target_info(${name},connect)
    }
    if [info exists target_info(${name},target)] {
	set target_info($type,target) $target_info(${name},target)
    }
    if [info exists target_info(${name},serial)] {
	set target_info($type,serial)  $target_info(${name},serial)
    }
    if [info exists target_info(${name},netport)] {
	set target_info($type,netport) $target_info(${name},netport)
    }
    if [info exists target_info(${name},baud)] {
	set target_info($type,baud)    $target_info(${name},baud)
    }
    if [info exists target_info(${name},x10)] {
	set target_info($type,x10)     $target_info(${name},x10)
    }
    if [info exists target_info(${name},fileid)] {
	set target_info($type,fileid)  $target_info(${name},fileid)
    }
    if [info exists target_info(${name},prompt)] {
	set target_info($type,prompt)  $target_info(${name},prompt)
    }
    if [info exists target_info(${name},abbrev)] {
	set target_info($type,abbrev)  $target_info(${name},abbrev)
    }
    if [info exists target_info(${name},ioport)] {
	set target_info($type,ioport)  $target_info(${name},ioport)
    }
}

#
# Set the current connection for target or host.
#
proc pop_config { type  } {
    global target_info

    set target_info(${type},name)	""
    set target_info(${type},ldflags)	""
    set target_info(${type},config)	""
    set target_info(${type},cflags)	""
    set target_info(${type},connect)	""
    set target_info(${type},target)	""
    set target_info(${type},serial)	""
    set target_info(${type},netport)	""
    set target_info(${type},baud)	""
    set target_info(${type},x10)	""
    set target_info(${type},fileid)	""
    set target_info(${type},prompt)	""
    set target_info(${type},abbrev)	""
    set target_info(${type},ioport)	""
}

#
# Unset the target connection.
#
proc pop_target { } {
    pop_config target
}


#
# Unset the host connection.
#
proc pop_host { } {
    pop_config host
}

#
# list all the configured targets.
#	returns:
#	    "" if there are no targets.
#	    else it returns a list of unique names.
#
proc list_targets { } {
    global target_info
    
    if ![info exists target_info] {
	return ""
    }

    set j ""
    set targs ""
    foreach i "[lsort [array names target_info]]" {
	set i "[lindex [split $i ","] 0]"
	if { $i == $j } {
	    continue
	} else {
	    lappend targs "[lindex [split $i ","] 0]"
	    set j $i
	}
    }
    return $targs
}

#
# Remove extraneous warnings we don't care about
#
proc prune_warnings { text } {
    # remove the \r part of "\r\n" so we don't break all the patterns
    # we want to match.
    regsub -all -- "\r" $text "" text

    # This is from sun4's.  Do it for all machines for now.
    # The "\\1" is to try to preserve a "\n" but only if necessary.
    if [ishost "sparc-*-sunos"] {
	regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text
    }

    # See Brendan for the raison d'etre of this one.
    if [ishost "alpha*-*-*"] {
        regsub -all "(^|\n)(/usr/(ucb|bin)/ld.*without exceptions was\[^\n\]+\n?)" $text "\\1" text
    }

 
    # Ignore these.
    regsub -all "(^|\n)\[^\n\]*linker input file unused since linking not done" $text "" text
    regsub -all "(^|\n)\[^\n\]*file path prefix \[^\n\]* never used" $text "" text

    # It might be tempting to get carried away and delete blank lines, etc.
    # Just delete *exactly* what we're ask to, and that's it.
    return $text
}

#
# Invoke the compiler. This gets interesting cause the compiler may
# not be on the same machine we're running DejaGnu on.
#
proc compile { arg } {
    global target_info
    global comp_output
    global CC
    
    if [info exists target_info(target,cflags)] {
	lappend options "$target_info(target,cflags)"
    }

    append options " $arg"

    verbose "Invoking the compiler as $CC $options"
    set comp_output [prune_warnings [execute_anywhere "$CC $options"]]
    return ${comp_output}
}

#
# Invoke the archiver. 
#
proc archive { arg } {
    global target_info
    global comp_output
    global AR
    
    if [info exists target_info(target,arflags)] {
	lappend options "$target_info(target,arflags)"
    }
    append options "$arg"

    verbose "Invoking the archiver as $AR $options"
    set comp_output [prune_warnings [execute_anywhere "$AR $options"]]
    return ${comp_output}
}

proc ranlib { arg } {
    global target_info
    global comp_output
    global RANLIB
    
    append options "$arg"

    verbose "Invoking the archiver as $RANLIB $options"
    set comp_output [prune_warnings [execute_anywhere "$RANLIB $options"]]
    return ${comp_output}
}

#
# Link a few objects together. This gets interesting cause the
# objects may not be on the same machine we're running DejaGnu on.
#
proc link_objects { arg } {
    global target_info
    global comp_output
    global LD
    
    set options "$arg"
    if [info exists target_info(target,ldlags)] {
	lappend options "$target_info(target,ldlags)"
    }
   
    set comp_output [execute_anywhere "$LD $args"]
    return [ prune_warnings $comp_output]
}

#
# Remotely execute something. This gets fun cause we can't expect an
# Unix machine on the other end. We'll use expect instead so we can
# connect using $connectmode. This is really designed for executing
# the tools to be tested, rather than the test cases.
#
proc execute_anywhere { cmdline } {
    global exec_output
    global target_info
  
    if ![info exists target_info(current,prompt)] {
	set prompt ""
    } else {
	set prompt $target_info(current,prompt)
    }
    
    # if we're running stuff that's hosted on the same machine
    if ![is3way] {
	verbose -log "Executing on local host: ${cmdline}" 2
    	set status [catch "exec ${cmdline}" exec_output]
	if ![string match "" ${exec_output}] {
	    # FIXME: This should be done below, after `else'.
	    verbose -log -- "${exec_output}" 2
	}
	return ${exec_output}
    } else {
	verbose -log "Executing on remote host: ${cmdline}" 2
	# open the connection
	verbose "Connecting to remote host" 2
	set shellid [remote_open "host"]
	if { $shellid < 0 } {
	    perror "Can't open connection to remote host"
	    return REMOTERROR
	}
#	stty -echo
	send -i $shellid "echo START ; $cmdline ; echo END\r\n"
	expect {
	    -i $shellid "echo START \; $cmdline \; echo END" {
	    }
	    default {
		warning "Never got command echo"
	    }
	}
	expect {
	    -i $shellid "START" {
		exp_continue
	    }
	    -i $shellid "END" {
		regsub -all "\]" $expect_out(buffer) "" exec_output
		regsub "END" $exec_output "" exec_output
	    }	    default {
		set exec_output $i
	    }
	}
    }

    if [info exists exec_output] {
	verbose "EXEC_OUTPUT = \"$exec_output\"" 2
    }
    
    
#    stty echo
    # close the connection
    remote_close $shellid
    
    if [info exists exec_output] {
	return $exec_output
    } else {
	return REMOTERROR
    }
}

#
# Get something resembling a prompt We can't grab more
# than the last word cause we have no real idea how long
# the prompt is. We also get the full prompt, but it's
# kinda useless as it might contain command numbers or
# paths that change. If we can't return a prompt, return
# null. so at least other patterns won't break.
#
proc getprompt { shellid } {
    global spawn_id

    if { $shellid < 0 } {
	perror "Invalid spawn id"
	return ""
    }

    set tries 0
    set text ""
  
    while { $tries <=3 } {
	verbose "Trying to get the remote host's prompt"
	send -i $shellid "ACK\r\n"
	expect {
	    -i $shellid -re "Kerberos rcmd failed.*$" {
		perror "Need to kinit"
		return ""
	    }
	    -i $shellid -re "$text*\[\r\n\]*" {
		return [lindex [split $expect_out(buffer) "\r\n"] 5]
		break
	    }
	    -i $shellid -re "Terminal type is.*tty.*\>" {
		return [lindex [split $expect_out(buffer) "\r\n"] 5]
		break
	    }
	    -i $shellid "" {
		warning "No prompt"
	    }
	    -i $shellid timeout {
		perror "Couldn't sync with the remote system"
	    }
	    -i $shellid eof {
		perror "Got EOF instead of a prompt"
	    }
	}
	incr tries
    }
    
    # see if we maxed out on errors
    if { $tries >= 3 } {
	warning "Couldn't get the prompt"
	return ""
    }
}


#
#
#
proc make { args } {
     perror "Unimplemented"
}