aboutsummaryrefslogtreecommitdiff
path: root/contrib/bluegnu2.0.3/lib/target.exp
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/target.exp')
-rw-r--r--contrib/bluegnu2.0.3/lib/target.exp520
1 files changed, 0 insertions, 520 deletions
diff --git a/contrib/bluegnu2.0.3/lib/target.exp b/contrib/bluegnu2.0.3/lib/target.exp
deleted file mode 100644
index fd69f8b..0000000
--- a/contrib/bluegnu2.0.3/lib/target.exp
+++ /dev/null
@@ -1,520 +0,0 @@
-# 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"
-}
generated by cgit v1.1 at 2024-07-17 00:54:36 +0000