# 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"
}