diff options
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/target.exp')
| -rw-r--r-- | contrib/bluegnu2.0.3/lib/target.exp | 520 |
1 files changed, 520 insertions, 0 deletions
diff --git a/contrib/bluegnu2.0.3/lib/target.exp b/contrib/bluegnu2.0.3/lib/target.exp new file mode 100644 index 0000000..1454dad --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/target.exp @@ -0,0 +1,520 @@ +# 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" +} |