diff options
Diffstat (limited to 'contrib/bluegnu2.0.3/lib')
26 files changed, 9822 insertions, 0 deletions
diff --git a/contrib/bluegnu2.0.3/lib/BlueGnu_target.itcl b/contrib/bluegnu2.0.3/lib/BlueGnu_target.itcl new file mode 100644 index 0000000..e1a9363 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/BlueGnu_target.itcl @@ -0,0 +1,105 @@ +# +# This script create a BlueGnu Target object +# + +verbose "BlueGnu Target Information ****" 3 + +proc BlueGnu {args} { + global nspTestSuite auto_path env + global testCases + + verbose "@@@@@@@@@@@ BlueGnu Target Initialization Procedure @@@@@@@@@@@" + verbose " auto_path:\n >$auto_path<" 5 + # + # Create the BlueGnu Target Object, which need to be returned. + # + namespace eval $nspTestSuite { + set args [uplevel 1 set args] + verbose "Arguments: $args (are not used)" 3 + verbose "======= BlueGnu Procedure creates Target Object" 3 + + + # Check argument and remove the local argument from the list + # All argument that do not contain a equal sign are also removed + set i 0 + catch {unset rmList} + foreach arg $args { + if {!$i} { + if {[llength [split $arg "="]] == 1} { + uplevel set eInterface $arg + lappend rmList $i + } + } + if {[string compare [lindex [split $arg "="] 0] \ + "testCases"] == 0} { + uplevel set testCases [lindex [split $arg "="] 1] + lappend rmList $i + } + incr i + } + if {[info exists rmList]} { + #puts "rmList >$rmList<" + for {set i [expr [llength $rmList] - 1]} {$i >= 0} {incr i -1} { + set args [lreplace $args $i $i] + } + } + verbose "Arguments (passed): $args" 5 + + verbose "Arguments (used): $args" 3 + set target [eval [concat createTarget $args]] + if {! [string match ::* $target]} { + set target [namespace current]::$target + } + debug {Target name >$target<} 3 + + # Save all Environment Variables so they may be cleared! + # + [$target environment] saveEnv + } + + # Return the name of the Target Object that has been created + # This should be the last statement + return [namespace eval $nspTestSuite {set target}] +} + +proc BlueGnu_start {} { + verbose "@@@@@@@@@@@ Starting BlueGnu Environment @@@@@@@@@@@" +} + +proc BlueGnu_load {} { + verbose "@@@@@@@@@@@ Load BlueGnu Environment @@@@@@@@@@@" +} + +proc BlueGnu_exit {} { + verbose "@@@@@@@@@@@ Exit BlueGnu Environment @@@@@@@@@@@" +} + +proc BlueGnu_version {} { + verbose "@@@@@@@@@@@ Version BlueGnu Environment @@@@@@@@@@@" +} + +proc BlueGnu_overwrite {szNamespace} { + # Modify output procedures to return instead of doing output + # + uplevel #0 { + rename send_user send_user_saved + rename send_error send_error_saved + rename send_log send_log_saved + } + proc ::send_user args "set ${szNamespace}::sending(USER) 1" + proc ::send_error args "set ${szNamespace}::sending(ERROR) 1" + proc ::send_log args "set ${szNamespace}::sending(LOG) 1" +} + +proc BlueGnu_restore {} { + # Restore original procedures + # + uplevel #0 { + rename send_user "" + rename send_error "" + rename send_log "" + rename send_user_saved send_user + rename send_error_saved send_error + rename send_log_saved send_log + } +} diff --git a/contrib/bluegnu2.0.3/lib/Default_target.itcl b/contrib/bluegnu2.0.3/lib/Default_target.itcl new file mode 100644 index 0000000..f66b20a --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/Default_target.itcl @@ -0,0 +1,82 @@ +# +# This script create a Default Target object +# + +verbose "Default Target Information ****" 3 + +proc Default {args} { + global nspTestSuite auto_path env + global testCases + + verbose "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" + verbose "@@@@@@@ Default Target Initialization Procedure" + verbose {@@@@@@@ auto_path:\n [join [split $auto_path] \ + "\n "]} 4 + # + # Create the Default Target Object, which need to be returned. + # + namespace eval $nspTestSuite { + set args [uplevel 1 set args] + verbose "Arguments: $args (are not used)" 3 + verbose "======= Default Procedure creates Target Object" 3 + + + # Check argument and remove the local argument from the list + # All argument that do not contain a equal sign are also removed + set i 0 + catch {unset rmList} + foreach arg $args { + if {!$i} { + if {[llength [split $arg "="]] == 1} { + uplevel set eInterface $arg + lappend rmList $i + } + } + if {[string compare [lindex [split $arg "="] 0] \ + "testCases"] == 0} { + uplevel set testCases [lindex [split $arg "="] 1] + lappend rmList $i + } + incr i + } + if {[info exists rmList]} { + #puts "rmList >$rmList<" + for {set i [expr [llength $rmList] - 1]} {$i >= 0} {incr i -1} { + set args [lreplace $args $i $i] + } + } + verbose "Arguments (passed): $args" 5 + + verbose "Arguments (used): $args" 3 + set target [eval [concat createTarget $args]] + if {! [string match ::* $target]} { + set target [namespace current]::$target + } + debug {Target name >$target<} 3 + + # Save all Environment Variables so they may be cleared! + # + [$target environment] saveEnv + } + + # Return the name of the Target Object that has been created + # This should be the last statement + return [namespace eval $nspTestSuite {set target}] +} + +proc Default_start {} { + verbose "@@@@@@@ Starting Default Environment" +} + +proc Default_load {} { + verbose "@@@@@@@ Load Default Environment" +} + +proc Default_exit {} { + verbose "@@@@@@@ Exit Default Environment" + verbose "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@" +} + +proc Default_version {} { + verbose "@@@@@@@ Version Default Environment" +} diff --git a/contrib/bluegnu2.0.3/lib/Types.itcl b/contrib/bluegnu2.0.3/lib/Types.itcl new file mode 100644 index 0000000..e2ef2b4 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/Types.itcl @@ -0,0 +1,216 @@ +# -*-Tcl-*- +# +# This [incr Tcl] library script contains type definitions +# +# +# Type super class +# + +if {[string length [info commands debug]] == 0} { + proc debug {args} {} +} + +class Type { + variable _value + variable _valueSaved + variable _voidPtr + variable _bVoid + protected variable _currentNamespace + protected variable _lProc + protected variable _upLevel + + constructor args { + debug {======= Constructor: [info class] $this $args} 3 + # Go up in the inheritance tree + debug { Go up inheritance tree} 4 + set level 1 + if {[string compare [info class] ::Type] != 0} { + debug { level set to >1<} 5 + while {[string compare [info class] \ + [uplevel $level {namespace current}]] != 0} { + debug {>[info class]< != >[uplevel $level\ + {namespace current}]<} 5 + incr level + debug { level incrmented to >$level<} 5 + } + debug {>[info class]< == >[uplevel $level\ + {namespace current}]<} 5 + incr level + regsub {^::} [uplevel $level {namespace current}] "" currentNamespace + } else { + regsub {^::} [uplevel {namespace current}] "" currentNamespace + } + set upLevel [expr [info level] - $level] + set lProc [info level $upLevel] + debug { Called from level: >$upLevel<} 4 + debug { Called from : >$lProc<} 4 + debug { Current namespace: >$currentNamespace<} 4 + #catch {puts " [uplevel "info body [lindex $lProc 0]"]"} + set _bVoid 0 + set _voidPtr 0 + if {[llength $args] > 0} { + set _value [lindex $args 0] + } else { + set _value "" + } + if {$upLevel == 0} { + debug {Called from global} 4 + set $this $_value + debug {this variable: [set $this]} 4 + trace variable $this rwu traceType + } elseif {[string length $currentNamespace] && \ + [string length $lProc]} { + debug {Called from procedure in namespace} 4 + debug { this: >$this<} 4 + debug {set $this >$_value<} + catch { + uplevel #$upLevel set [namespace tail $this] \"$_value\" + uplevel #$upLevel trace variable [namespace tail $this] \ + rwu traceType + } szErrMsg; debug { szErrMsg: >$szErrMsg<} 4 + } elseif {[string length $currentNamespace]} { + debug {Called from namespace} 4 + debug {set $this >$_value<} + catch { + namespace eval ${currentNamespace} "set $this \"$_value\"\n\ + trace variable $this rwu traceType" + } szErrMsg + debug { TRACE set} 4 + debug { szErrMsg: >$szErrMsg<} 4 + } else { + debug {Called from procedure} 4 + set var [namespace tail $this] + uplevel "set $var $_value" + debug {this variable: [uplevel "set $var"]} 4 + uplevel "trace variable $var rwu traceType" + } + } + + destructor { + debug {======= destructor $this} 3 + set calledFrom [lindex [split [info level [expr [info level] - 1]]] 0] + debug { calledFrom: >$calledFrom<} 4 + debug { >[info level [expr [info level] - 1]]<} 4 + # just return when called from traceType + if {[string compare $calledFrom "traceType"] != 0} { + set var [namespace tail $this] + debug { var: >$var<} 4 + debug { >[join [trace vinfo $var]]<} 4 + debug { >[uplevel [join [trace vinfo $var]]]<} 4 + debug { >[join [uplevel "trace vinfo $var"]]<} 4 + catch { + debug {eval uplevel \"trace vdelete $var [join [uplevel "trace vinfo $var"]]\"} 4 + eval uplevel "trace vdelete $var [join [uplevel "trace vinfo $var"]]" + uplevel unset $var + } szErrMsg; debug { #### szErrMsg: >$szErrMsg<} 4 + } + } + + public method value {args} { + if {[llength $args] > 0} { + set _value [lindex $args 0] + } + return $_value + } + + public method setNull {{ptr 0}} { + set _voidPtr $ptr + set _bVoid 1 + } + + public method unsetNull {} { + set _bVoid 0 + } + + public method isNull {} { + return $_bVoid + } + + public method getNull {} { + return $_voidPtr + } +} + +proc traceType {name1 name2 ops} { + debug {======= traceType >$name1< >$name2< >$ops<} 3 + upvar $name1 var + set upLevel [expr [info level] - 1] + set lProc [info level $upLevel] + regsub {^::} [uplevel {namespace current}] "" currentNamespace + debug { Called from level: >$upLevel<} 4 + debug { level namespace : >[uplevel #$upLevel namespace current]<} 4 + debug { Called from : >$lProc<} 4 + debug { Current namespace: >$currentNamespace<} 4 + if {$upLevel == 0} { + debug {Called from global} 4 + switch $ops { + r { + set var [uplevel $name1 value] + } + w { + if [catch {$name1 value [set var]}] { + uplevel "$name1 value [set var]" + } + } + u { + uplevel delete object $name1 + } + } + } elseif {[string length $currentNamespace] && \ + [string length $lProc]} { + debug {Called from procedure in namespace} 4 + set var [uplevel ::itcl::find objects $name1] + debug { $name1 ->$var< = ><} 4 + switch $ops { + r { + uplevel set $name1 [uplevel $var value] + } + w { + if [catch {uplevel $var value [uplevel set $name1]} szErrMsg] { + debug {####### Error: $szErrMsg} 4 + + } + } + u { + uplevel delete object $name1 + } + } + } elseif {[string length $currentNamespace]} { + debug {Called from namespace} 4 + set var [uplevel "namespace which -variable $name1"] + debug { $name1 ->$var< = ><} 4 + switch $ops { + r { + set $var [$var value] + } + w { + if [catch {$var value [set $var]} szErrMsg] { + debug {####### Error: $szErrMsg} 4 + + } + } + u { + debug {Deleting >$name1<} 4 + debug { [namespace current]} 4 + catch {delete object $name1} + debug { DONE!} 4 + } + } + } else { + debug {Called from procedure} 4 + switch $ops { + r { + set $name1 [$name1 value] + } + w { + if [catch {$name1 value [uplevel set $name1]}] { + uplevel "$name1 value [set $name1]" + } + } + u { + delete object $name1 + } + } + } +} + diff --git a/contrib/bluegnu2.0.3/lib/bluegnu.itcl b/contrib/bluegnu2.0.3/lib/bluegnu.itcl new file mode 100644 index 0000000..da02c8b --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/bluegnu.itcl @@ -0,0 +1,22 @@ +#! iexpect +# +# This program is an Object Oriented version of the +# DejaGnu's runtest program and DejaGnu is a subset. +# +# BlueGnu implements a super set of a DejaGnu compatible test Framework +# +# Copyright (C) 1998 jotOmega dsc, Inc. + +#This file is part of the BlueGnu Test Framework. +# +# Load Application Framework Class and associated data +# +source $env(BLUEGNULIB)/testSessionApplication.itcl + +append auto_path " [pwd]/lib" + +set objApplication [::BlueGnu::Application #auto szName=BlueGnu] + +$objApplication processArguments argv + +$objApplication execute diff --git a/contrib/bluegnu2.0.3/lib/bug.exp b/contrib/bluegnu2.0.3/lib/bug.exp new file mode 100644 index 0000000..5d52182 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/bug.exp @@ -0,0 +1,125 @@ +# 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) + +#load_lib remote.exp + +# +# set target variables only if needed. +# +global targetname +global connectmode +global env + +if ![info exists targetname] { + if [info exists env(TARGETNAME)] { + set targetname $env(TARGETNAME) + } else { + puts stderr "ERROR: Need a target name for the board." + puts stderr " Use the --name option\n" + exit 1 + } +} + +# the default connect program to use +if ![info exists connectmode] { + set connectmode "tip" + warning "Using default of $connectmode for target communication." +} + +# +# Load a file into the bug monitor +# +proc bug_load { shell_id file } { + global OBJCOPY + global shell_prompt + + if { $shell_id < 0 } { + warning "$file not executed because there is no target." + return -1 + } + + # NOTE: this requires OBJCOPY to be tested first + catch "exec $OBJCOPY -O srec $file $file.srec" result + if ![string match "" $result] { + perror "Couldn't convert to srecord for downloading" + return -1 + } + + send -i $shell_id "lo 0\r" + expect { + -i $shell_id "lo 0*" { + verbose "Got load command echo" 0 + } + -i $shell_id timeout { + perror "Load command didn't echo back" + return -1 + } + } + + if { [download $file.srec $shell_id] < 0 } { + return -1 + } + + send -i $shell_id "\r\r" + expect { + -i $shell_id -re "$shell_prompt.*$" { + } + -i $shell_id timeout { + perror "Load command didn't echo back" + return -1 + } + } + + catch "exec rm -f $file.srec" + return 0 +} + +# +# Execute a program +# +proc bug_execute { shell_id addr } { + global shell_prompt + global exec_output + + set exec_output "" + + if { $shell_id < 0 } { + warning "$arg not executed because there is no target." + return -1 + } + send -i $shell_id "go $addr\r" + verbose "Sent execute command" + expect { + -i $shell_id "*Effective address: $addr" { + exp_continue + } + -i $shell_id -re "$shell_prompt.*$" { + set exec_output $expect_out(buffer) + return 0 + } + -i $shell_id timeout { + perror "Couldn't execute program (timed out)." + return 1 + } + } + +} + diff --git a/contrib/bluegnu2.0.3/lib/debugger.exp b/contrib/bluegnu2.0.3/lib/debugger.exp new file mode 100644 index 0000000..8dd0701 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/debugger.exp @@ -0,0 +1,252 @@ +# 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) + +# +# Dump the values of a shell expression representing variable +# names. +proc dumpvars { args } { + uplevel 1 [list foreach i [uplevel 1 "info vars $args"] { + if { [catch "array names $i" names ] } { + eval "puts \"${i} = \$${i}\"" + } else { + foreach k $names { + eval "puts \"$i\($k\) = \$$i\($k\)\"" + } + } + } + ] +} + +# +# dump the values of a shell expression representing variable +# names. +proc dumplocals { args } { + uplevel 1 [list foreach i [uplevel 1 "info locals $args"] { + if { [catch "array names $i" names ] } { + eval "puts \"${i} = \$${i}\"" + } else { + foreach k $names { + eval "puts \"$i\($k\) = \$$i\($k\)\"" + } + } + } + ] +} +# +# Dump the body of procedures specified by a regexp. +# +proc dumprocs { args } { + foreach i [info procs $args] { + puts "\nproc $i \{ [info args $i] \} \{ [info body $i]\}" + } +} + +# +# Dump all the current watchpoints +# +proc dumpwatch { args } { + foreach i [uplevel 1 "info vars $args"] { + set tmp "" + if { [catch "uplevel 1 array name $i" names] } { + set tmp [uplevel 1 trace vinfo $i] + if ![string match "" $tmp] { + puts "$i $tmp" + } + } else { + foreach k $names { + set tmp [uplevel 1 trace vinfo [set i]($k)] + if ![string match "" $tmp] { + puts "[set i]($k) = $tmp" + } + } + } + } +} + +# +# Trap a watchpoint for an array +# +proc watcharray { element type} { + upvar [set array]($element) avar + case $type { + "w" { puts "New value of [set array]($element) is $avar" } + "r" { puts "[set array]($element) (= $avar) was just read" } + "u" { puts "[set array]($element) (= $avar) was just unset" } + } +} + +proc watchvar { v type } { + upvar $v var + case $type { + "w" { puts "New value of $v is $var" } + "r" { puts "$v (=$var) was just read" } + "u" { puts "$v (=$var) was just unset" } + } +} + +# +# Watch when a variable is written +# +proc watchunset { arg } { + if { [catch "uplevel 1 array name $arg" names ] } { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable $arg u watchvar + } else { + foreach k $names { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable [set arg]($k) u watcharray + } + } +} + +# +# Watch when a variable is written +# +proc watchwrite { arg } { + if { [catch "uplevel 1 array name $arg" names ] } { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable $arg w watchvar + } else { + foreach k $names { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable [set arg]($k) w watcharray + } + } +} + +# +# Watch when a variable is read +# +proc watchread { arg } { + if { [catch "uplevel 1 array name $arg" names ] } { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable $arg r watchvar + } else { + foreach k $names { + if ![uplevel 1 info exists $arg] { + puts stderr "$arg does not exist" + return + } + uplevel 1 trace variable [set arg]($k) r watcharray + } + } +} + +# +# Delete a watch point +# +proc watchdel { args } { + foreach i [uplevel 1 "info vars $args"] { + set tmp "" + if { [catch "uplevel 1 array name $i" names] } { + catch "uplevel 1 trace vdelete $i w watchvar" + catch "uplevel 1 trace vdelete $i r watchvar" + catch "uplevel 1 trace vdelete $i u watchvar" + } else { + foreach k $names { + catch "uplevel 1 trace vdelete [set i]($k) w watcharray" + catch "uplevel 1 trace vdelete [set i]($k) r watcharray" + catch "uplevel 1 trace vdelete [set i]($k) u watcharray" + } + } + } +} + +# +# This file creates GDB style commands for the Tcl debugger +# +proc print { var } { + puts "$var" +} + +proc quit { } { + log_summary + exit +} + +proc bt { } { + puts "[w]" +} + +# +# create some stub procedures since we can't alias the command names +# +proc dp { args } { + uplevel 1 dumprocs $args +} + +proc dv { args } { + uplevel 1 dumpvars $args +} + +proc dl { args } { + uplevel 1 dumplocals $args +} + +proc dw { args } { + uplevel 1 dumpwatch $args +} + +proc q { } { + quit +} + +proc p { args } { + uplevel 1 print $args +} + +proc wu { args } { + uplevel 1 watchunset $args +} + +proc ww { args } { + uplevel 1 watchwrite $args +} + +proc wr { args } { + uplevel 1 watchread $args +} + +proc wd { args } { + uplevel 1 watchdel $args +} + + + + + + + diff --git a/contrib/bluegnu2.0.3/lib/dejagnu.itcl b/contrib/bluegnu2.0.3/lib/dejagnu.itcl new file mode 100644 index 0000000..35957cc --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/dejagnu.itcl @@ -0,0 +1,81 @@ +#! iexpect +# +# This program is a full compatible Object Oriented version of +# DejaGnu's runtest program +# +# Copyright (C) 1998 jotOmega dsc, Inc. + +#This file is part of BlueGnu. + +################################################################ +# Preemble +################################################################ +# Check Environment variables: +# +# BLUEGNULIBS +# TESTSUITEROOT +# + +if [info exists env(BLUEGNULIBS)] { + set szToolsLib $env(BLUEGNULIBS) +} else { + set szToolsLib [file dirname $argv0] + set PWD [pwd] + cd $szToolsLib + set szToolsLib [pwd] + cd $PWD + regsub {/bin$} $szToolsLib {/lib/bluegnu} szToolsLib + set env(BLUEGNULIBS) $szToolsLib +} + +if [info exists env(TESTSUITEROOT)] { + set szRootDir $env(TESTSUITEROOT) +} else { + set szRootDir [pwd] + set env(TESTSUITEROOT) $szRootDir +} +if [info exists env(DEBUG)] { + set bDebug 1 +} else { + set bDebug 0 +} + +# Make sure that the testsuite root directory is our working directory +# all tests name are relative to this directory +cd $szRootDir + +# set the default tool. All test are relative to this directory. +# +set szTool $szRootDir +catch {unset lTool} +lappend lTool $szTool + +# +# source basic utilities +# +source $szToolsLib/testSessionClasses.itcl +source $szToolsLib/testSessionFramework.itcl +#source $szToolsLib/testSessionUtils.itcl +# +verbose "Library : >$szToolsLib<" +verbose "TestSuite: >$szRootDir<" +verbose "$argv0 $argv" 5 +# +# from here we should use only defined utilities +################################################################ +################################################################ + +set szRootName [file rootname $argv0] +puts "RootName : >$szRootName<" + +::TestSession::Queue Q0 +::TestSession::DejaGnu E0; # will load dejagnu.tcl + +while {! [catch {Q0 pop} T]} { + clone_output "Q0 element: $T" + runtest E0 $T +} + +delete object Q0 +delete object E0 + diff --git a/contrib/bluegnu2.0.3/lib/dejagnu.tcl b/contrib/bluegnu2.0.3/lib/dejagnu.tcl new file mode 100644 index 0000000..f5b48bd --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/dejagnu.tcl @@ -0,0 +1,1130 @@ +# +# Procedures that are used within DejaGnu +# +puts "DejaGnu=======1.3" + +set frame_version 1.3 +if ![info exists argv0] { + send_error "Must use a version of Expect greater than 5.0\n" + exit 1 +} + +# +# trap some signals so we know whats happening. These definitions are only +# temporary until we read in the library stuff +# +trap { send_user "\nterminated\n"; exit 1 } SIGTERM +trap { send_user "\ninterrupted by user\n"; exit 1 } SIGINT +trap { send_user "\nsegmentation violation\n"; exit 1 } SIGSEGV +trap { send_user "\nsigquit\n"; exit 1 } SIGQUIT + + +# +# Initialize a few global variables used by all tests. +# `reset_vars' resets several of these, we define them here to document their +# existence. In fact, it would be nice if all globals used by some interface +# of dejagnu proper were documented here. +# +# Keep these all lowercase. Interface variables used by the various +# testsuites (eg: the gcc testsuite) should be in all capitals +# (eg: TORTURE_OPTIONS). +# +set mail_logs 0 ;# flag for mailing of summary and diff logs +set psum_file "latest" ;# file name of previous summary to diff against +set testcnt 0 ;# number of testcases that ran +set passcnt 0 ;# number of testcases that passed +set failcnt 0 ;# number of testcases that failed +set xfailcnt 0 ;# number of testcases expected to fail which did +set xpasscnt 0 ;# number of testcases that passed unexpectedly +set warncnt 0 ;# number of warnings +set errcnt 0 ;# number of errors +set unsupportedcnt 0 ;# number of testcases that can't run +set unresolvedcnt 0 ;# number of testcases whose result is unknown +set untestedcnt 0 ;# number of untested testcases +set exit_status 0 ;# exit code returned by this program +set xfail_flag 0 +set xfail_prms 0 +set sum_file "" ;# name of the file that contains the summary log +set base_dir "" ;# the current working directory +set logname "" ;# the users login name +set passwd "" +set prms_id 0 ;# GNATS prms id number +set bug_id 0 ;# optional bug id number +set dir "" ;# temp variable for directory names +set srcdir "." ;# source directory containing the test suite +set ignoretests "" ;# list of tests to not execute +set objdir "." ;# directory where test case binaries live +set makevars "" ;# FIXME: Is this used anywhere? +set reboot 0 +set configfile site.exp ;# (local to this file) +set multipass "" ;# list of passes and var settings +set target_abbrev "unix" ;# environment (unix, sim, vx, etc.). +set errno ""; ;# +# +# set communication parameters here +# +set netport "" +set targetname "" +set connectmode "" +set serialport "" +set baud "" +# +# These describe the host and target environments. +# +set build_triplet "" ;# type of architecture to run tests on +set build_os "" ;# type of os the tests are running on +set build_vendor "" ;# vendor name of the OS or workstation the test are running on +set build_cpu "" ;# type of the cpu tests are running on +set host_triplet "" ;# type of architecture to run tests on, sometimes remotely +set host_os "" ;# type of os the tests are running on +set host_vendor "" ;# vendor name of the OS or workstation the test are running on +set host_cpu "" ;# type of the cpu tests are running on +set target_triplet "" ;# type of architecture to run tests on, final remote +set target_os "" ;# type of os the tests are running on +set target_vendor "" ;# vendor name of the OS or workstation the test are running on +set target_cpu "" ;# type of the cpu tests are running on +set target_alias "" ;# standard abbreviation of target + +# +# some convenience abbreviations +# +if ![info exists hex] { + set hex "0x\[0-9A-Fa-f\]+" +} +if ![info exists decimal] { + set decimal "\[0-9\]+" +} + +# +# set the base dir (current working directory) +# +set base_dir [pwd] + +# +# These are tested in case they are not initialized in $configfile. They are +# tested here instead of the init module so they can be overridden by command +# line options. +# +if ![info exists all_flag] { + set all_flag 0 +} +if ![info exists binpath] { + set binpath "" +} +if ![info exists debug] { + set debug 0 +} +if 0 { + if ![info exists options] { + set options "" + } +} +if ![info exists outdir] { + set outdir "." +} +if ![info exists reboot] { + set reboot 1 +} +if ![info exists all_runtests] { + # FIXME: Can we create an empty array? + # we don't have to (JWN 20 March 1998) + #set all_runtests(empty) "" +} +if ![info exists tracelevel] { + set tracelevel 0 +} +if ![info exists verbose] { + set verbose 0 +} + +# +# verbose [-n] [-log] [--] message [level] +# +# Print MESSAGE if the verbose level is >= LEVEL. +# The default value of LEVEL is 1. +# "-n" says to not print a trailing newline. +# "-log" says to add the text to the log file even if it won't be printed. +# Note that the apparent behaviour of `send_user' dictates that if the message +# is printed it is also added to the log file. +# Use "--" if MESSAGE begins with "-". +# +# This is defined here rather than in framework.exp so we can use it +# while still loading in the support files. +# +proc verbose { args } { + global verbose + set newline 1 + set logfile 0 + + set i 0 + if { [string index [lindex $args 0] 0] == "-" } { + for { set i 0 } { $i < [llength $args] } { incr i } { + if { [lindex $args $i] == "--" } { + incr i + break + } elseif { [lindex $args $i] == "-n" } { + set newline 0 + } elseif { [lindex $args $i] == "-log" } { + set logfile 1 + } elseif { [string index [lindex $args $i] 0] == "-" } { + clone_output "ERROR: verbose: illegal argument: [lindex $args $i]" + return + } else { + break + } + } + if { [llength $args] == $i } { + clone_output "ERROR: verbose: nothing to print" + return + } + } + + set level 1 + if { [llength $args] > $i + 1 } { + set level [lindex $args [expr $i+1]] + } + set message [lindex $args $i] + + if { $verbose >= $level } { + # There is no need for the "--" argument here, but play it safe. + # We assume send_user also sends the text to the log file (which + # appears to be the case though the docs aren't clear on this). + if { $newline } { + send_user -- "$message\n" + } else { + send_user -- "$message" + } + } elseif { $logfile } { + if { $newline } { + send_log "$message\n" + } else { + send_log "$message" + } + } +} + +# +# Transform a tool name to get the installed name. +# target_triplet is the canonical target name. target_alias is the +# target name used when configure was run. +# +proc transform { name } { + global target_triplet + global target_alias + global host_triplet + + if [string match $target_triplet $host_triplet] { + return $name + } + if [string match "native" $target_triplet] { + return $name + } + if [string match "" $target_triplet] { + return $name + } else { + set tmp ${target_alias}-${name} + verbose "Transforming $name to $tmp" + return $tmp + } +} + +# +# findfile arg0 [arg1] [arg2] +# +# Find a file and see if it exists. If you only care about the false +# condition, then you'll need to pass a null "" for arg1. +# arg0 is the filename to look for. If the only arg, +# then that's what gets returned. If this is the +# only arg, then if it exists, arg0 gets returned. +# if it doesn't exist, return only the prog name. +# arg1 is optional, and it's what gets returned if +# the file exists. +# arg2 is optional, and it's what gets returned if +# the file doesn't exist. +# +proc findfile { args } { + # look for the file + verbose "Seeing if [lindex $args 0] exists." 2 + if [file exists [lindex $args 0]] { + if { [llength $args] > 1 } { + verbose "Found file, returning [lindex $args 1]" + return [lindex $args 1] + } else { + verbose "Found file, returning [lindex $args 0]" + return [lindex $args 0] + } + } else { + if { [llength $args] > 2 } { + verbose "Didn't find file, returning [lindex $args 2]" + return [lindex $args 2] + } else { + verbose "Didn't find file, returning [file tail [lindex $args 0]]" + return [transform [file tail [lindex $args 0]]] + } + } +} + +# +# load_file [-1] [--] file1 [ file2 ... ] +# +# Utility to source a file. All are sourced in order unless the flag "-1" +# is given in which case we stop after finding the first one. +# The result is 1 if a file was found, 0 if not. +# If a tcl error occurs while sourcing a file, we print an error message +# and exit. +# +# ??? Perhaps add an optional argument of some descriptive text to add to +# verbose and error messages (eg: -t "library file" ?). +# +proc load_file { args } { + set i 0 + set only_one 0 + if { [lindex $args $i] == "-1" } { + set only_one 1 + incr i + } + if { [lindex $args $i] == "--" } { + incr i + } + + set found 0 + foreach file [lrange $args $i end] { + verbose "Looking for $file" 2 + if [file exists $file] { + set found 1 + verbose "Found $file" + if { [catch "uplevel #0 source $file"] == 1 } { + send_error "ERROR: tcl error sourcing $file.\n" + global errorInfo + if [info exists errorInfo] { + send_error "$errorInfo\n" + } + exit 1 + } + if $only_one { + break + } + } + } + return $found +} + +# +# Parse the arguments the first time looking for these. We will ultimately +# parse them twice. Things are complicated because: +# - we want to parse --verbose early on +# - we don't want config files to override command line arguments +# (eg: $base_dir/$configfile vs --host/--target; $DEJAGNU vs --baud, +# --connectmode, and --name) +# - we need some command line arguments before we can process some config files +# (eg: --objdir before $objdir/$configfile, --host/--target before $DEJAGNU) +# The use of `arg_host_triplet' and `arg_target_triplet' lets us avoid parsing +# the arguments three times. +# + +set arg_host_triplet "" +set arg_target_triplet "" +set arg_build_triplet "" +set argc [ llength $argv ] +for { set i 0 } { $i < $argc } { incr i } { + set option [lindex $argv $i] + + # make all options have two hyphens + switch -glob -- $option { + "--*" { + } + "-*" { + set option "-$option" + } + } + + # split out the argument for options that take them + switch -glob -- $option { + "--*=*" { + set optarg [lindex [split $option =] 1] + } + "--ba*" - + "--bu*" - + "--co*" - + "--ho*" - + "--i*" - + "--m*" - + "--n*" - + "--ob*" - + "--ou*" - + "--sr*" - + "--st*" - + "--ta*" - + "--to*" { + incr i + set optarg [lindex $argv $i] + } + } + + switch -glob -- $option { + "--bu*" { # (--build) the build host configuration + set arg_build_triplet $optarg + continue + } + + "--ho*" { # (--host) the host configuration + set arg_host_triplet $optarg + continue + } + + "--ob*" { # (--objdir) where the test case object code lives + set objdir $optarg + continue + } + + "--sr*" { # (--srcdir) where the testsuite source code lives + set srcdir $optarg + continue + } + + "--ta*" { # (--target) the target configuration + set arg_target_triplet $optarg + continue + } + + "--to*" { # (--tool) specify tool name + set tool $optarg + continue + } + + "--v" - + "--verb*" { # (--verbose) verbose output + incr verbose + continue + } + } +} +verbose "Verbose level is $verbose" + +# +# get the users login name +# +if [string match "" $logname] { + if [info exists env(USER)] { + set logname $env(USER) + } else { + if [info exists env(LOGNAME)] { + set logname $env(LOGNAME) + } else { + # try getting it with whoami + catch "set logname [exec whoami]" tmp + if [string match "*couldn't find*to execute*" $tmp] { + # try getting it with who am i + unset tmp + catch "set logname [exec who am i]" tmp + if [string match "*Command not found*" $tmp] { + send_user "ERROR: couldn't get the users login name\n" + set logname "Unknown" + } else { + set logname [lindex [split $logname " !"] 1] + } + } + } + } +} +verbose "Login name is $logname" + +# +# Begin sourcing the config files. +# All are sourced in order. +# +# Search order: +# $HOME/.dejagnurc -> $base_dir/$configfile -> $objdir/$configfile +# -> installed -> $DEJAGNU +# +# ??? It might be nice to do $HOME last as it would allow it to be the +# ultimate override. Though at present there is still $DEJAGNU. +# +# For the normal case, we rely on $base_dir/$configfile to set +# host_triplet and target_triplet. +# + +load_file ~/.dejagnurc $base_dir/$configfile + +# +# If objdir didn't get set in $base_dir/$configfile, set it to $base_dir. +# Make sure we source $objdir/$configfile in case $base_dir/$configfile doesn't +# exist and objdir was given on the command line. +# + +if [expr [string match "." $objdir] || [string match $srcdir $objdir]] { + set objdir $base_dir +} else { + load_file $objdir/$configfile +} +verbose "Using test sources in $srcdir" +verbose "Using test binaries in $objdir" + +set execpath [file dirname $argv0] +set libdir [file dirname $execpath]/bluegnu +if [info exists env(BLUEGNULIBS)] { + set libdir $env(BLUEGNULIBS) +} +verbose "Using $libdir to find libraries" + +# +# If the host or target was given on the command line, override the above +# config files. We allow $DEJAGNU to massage them though in case it would +# ever want to do such a thing. +# +if { $arg_host_triplet != "" } { + set host_triplet $arg_host_triplet +} +if { $arg_build_triplet != "" } { + set build_triplet $arg_build_triplet +} + +# if we only specify --host, then that must be the build machne too, and we're +# stuck using the old functionality of a simple cross test +if [expr { $build_triplet == "" && $host_triplet != "" } ] { + set build_triplet $host_triplet +} +# if we only specify --build, then we'll use that as the host too +if [expr { $build_triplet != "" && $host_triplet == "" } ] { + set host_triplet $build_triplet +} +unset arg_host_triplet arg_build_triplet + +# +# If the build machine type hasn't been specified by now, use config.guess. +# + +if [expr { $build_triplet == "" && $host_triplet == ""} ] { + # find config.guess + foreach dir "$libdir $libdir/.. $srcdir/.. $srcdir/../.." { + verbose "Looking for $dir" 2 + if [file exists $dir/config.guess] { + set config_guess $dir/config.guess + verbose "Found $dir/config.guess" + break + } + } + + # get the canonical config name + if ![info exists config_guess] { + send_error "ERROR: Couldn't guess configuration.\n" + exit 1 + } + catch "exec $config_guess" build_triplet + case $build_triplet in { + { "No uname command or uname output not recognized" "Unable to guess system type" } { + verbose "WARNING: Uname output not recognized" + set build_triplet unknown + } + } + verbose "Assuming build host is $build_triplet" + if { $host_triplet == "" } { + set host_triplet $build_triplet + } + +} + +# +# Figure out the target. If the target hasn't been specified, then we have to assume +# we are native. +# +if { $arg_target_triplet != "" } { + set target_triplet $arg_target_triplet +} elseif { $target_triplet == "" } { + set target_triplet $build_triplet + verbose "Assuming native target is $target_triplet" 2 +} +unset arg_target_triplet +# +# Default target_alias to target_triplet. +# +if ![info exists target_alias] { + set target_alias $target_triplet +} + +# +# Find and load the global config file if it exists. +# The global config file is used to set the connect mode and other +# parameters specific to each particular target. +# These files assume the host and target have been set. +# + +if { [load_file -- $libdir/$configfile] == 0 } { + # If $DEJAGNU isn't set either then there isn't any global config file. + # Warn the user as there really should be one. + if { ! [info exists env(DEJAGNU)] } { + send_error "WARNING: Couldn't find the global config file.\n" + } +} + +if [info exists env(DEJAGNU)] { + if { [load_file -- $env(DEJAGNU)] == 0 } { + # It may seem odd to only issue a warning if there isn't a global + # config file, but issue an error if $DEJAGNU is erroneously defined. + # Since $DEJAGNU is set there is *supposed* to be a global config file, + # so the current behaviour seems reasonable. + send_error "ERROR: global config file $env(DEJAGNU) not found.\n" + exit 1 + } +} + +# +# parse out the config parts of the triplet name +# + +# build values +if { $build_cpu == "" } { + regsub -- "-.*-.*" ${build_triplet} "" build_cpu +} +if { $build_vendor == "" } { + regsub -- "^\[a-z0-9\]*-" ${build_triplet} "" build_vendor + regsub -- "-.*" ${build_vendor} "" build_vendor +} +if { $build_os == "" } { + regsub -- ".*-.*-" ${build_triplet} "" build_os +} + +# host values +if { $host_cpu == "" } { + regsub -- "-.*-.*" ${host_triplet} "" host_cpu +} +if { $host_vendor == "" } { + regsub -- "^\[a-z0-9\]*-" ${host_triplet} "" host_vendor + regsub -- "-.*" ${host_vendor} "" host_vendor +} +if { $host_os == "" } { + regsub -- ".*-.*-" ${host_triplet} "" host_os +} + +# target values +if { $target_cpu == "" } { + regsub -- "-.*-.*" ${target_triplet} "" target_cpu +} +if { $target_vendor == "" } { + regsub -- "^\[a-z0-9\]*-" ${target_triplet} "" target_vendor + regsub -- "-.*" ${target_vendor} "" target_vendor +} +if { $target_os == "" } { + regsub -- ".*-.*-" ${target_triplet} "" target_os +} + +# +# Parse the command line arguments. +# + +set argc [ llength $argv ] +for { set i 0 } { $i < $argc } { incr i } { + set option [ lindex $argv $i ] + + # make all options have two hyphens + switch -glob -- $option { + "--*" { + } + "-*" { + set option "-$option" + } + } + + # split out the argument for options that take them + switch -glob -- $option { + "--*=*" { + set optarg [lindex [split $option =] 1] + } + "--ba*" - + "--bu*" - + "--co*" - + "--ho*" - + "--i*" - + "--m*" - + "--n*" - + "--ob*" - + "--ou*" - + "--sr*" - + "--st*" - + + "--ta*" - + "--to*" { + incr i + set optarg [lindex $argv $i] + } + } + + switch -glob -- $option { + "--V*" - + "--vers*" { # (--version) version numbers + send_user "Expect version is\t[exp_version]\n" + send_user "Tcl version is\t\t[ info tclversion ]\n" + send_user "Framework version is\t$frame_version\n" + exit + } + + "--v*" { # (--verbose) verbose output + # Already parsed. + continue + } + + "--bu*" { # (--build) the build host configuration + # Already parsed (and don't set again). Let $DEJAGNU rename it. + continue + } + + "--ho*" { # (--host) the host configuration + # Already parsed (and don't set again). Let $DEJAGNU rename it. + continue + } + + "--ta*" { # (--target) the target configuration + # Already parsed (and don't set again). Let $DEJAGNU rename it. + continue + } + + "--a*" { # (--all) print all test output to screen + set all_flag 1 + verbose "Print all test output to screen" + continue + } + + "--ba*" { # (--baud) the baud to use for a serial line + set baud $optarg + verbose "The baud rate is now $baud" + continue + } + + "--co*" { # (--connect) the connection mode to use + set connectmode $optarg + verbose "Comm method is $connectmode" + continue + } + + "--d*" { # (--debug) expect internal debugging + if [file exists ./dbg.log] { + catch "exec rm -f ./dbg.log" + } + if { $verbose > 2 } { + exp_internal -f dbg.log 1 + } else { + exp_internal -f dbg.log 0 + } + verbose "Expect Debugging is ON" + continue + } + + "--D[01]" { # (-Debug) turn on Tcl debugger + verbose "Tcl debugger is ON" + continue + } + + "--m*" { # (--mail) mail the output + set mailing_list $optarg + set mail_logs 1 + verbose "Mail results to $mailing_list" + continue + } + + "--r*" { # (--reboot) reboot the target + set reboot 1 + verbose "Will reboot the target (if supported)" + continue + } + + "--ob*" { # (--objdir) where the test case object code lives + # Already parsed, but parse again to make sure command line + # options override any config file. + set objdir $optarg + verbose "Using test binaries in $objdir" + continue + } + + "--ou*" { # (--outdir) where to put the output files + set outdir $optarg + verbose "Test output put in $outdir" + continue + } + + "*.exp" { # specify test names to run + set all_runtests($option) "" + verbose "Running only tests $option" + continue + } + + "*.exp=*" { # specify test names to run + set j [string first "=" $option] + set tmp [list [string range $option 0 [expr $j - 1]] \ + [string range $option [expr $j + 1] end]] + set all_runtests([lindex $tmp 0]) [lindex $tmp 1] + verbose "Running only tests $option" + unset tmp j + continue + } + + "--i*" { # (--ignore) specify test names to exclude + set ignoretests $optarg + verbose "Ignoring test $ignoretests" + continue + } + + "--sr*" { # (--srcdir) where the testsuite source code lives + # Already parsed, but parse again to make sure command line + # options override any config file. + + set srcdir $optarg + continue + } + + "--st*" { # (--strace) expect trace level + set tracelevel $optarg + strace $tracelevel + verbose "Source Trace level is now $tracelevel" + continue + } + + "--n*" { # (--name) the target's name + # ??? `targetname' is a confusing word to use here. + set targetname $optarg + verbose "Target name is now $targetname" + continue + } + + "--to*" { # (--tool) specify tool name + set tool $optarg + verbose "Testing $tool" + continue + } + + "[A-Z]*=*" { # process makefile style args like CC=gcc, etc... + if [regexp "^(\[A-Z_\]+)=(.*)$" $option junk var val] { + if {0 > [lsearch -exact $makevars $var]} { + lappend makevars "$var" + set $var $val + } else { + set $var [concat [set $var] $val] + } + verbose "$var is now [set $var]" + #append makevars "set $var $val;" ;# FIXME: Used anywhere? + unset junk var val + } else { + send_error "Illegal variable specification:\n" + send_error "$option\n" + } + continue + } + + "--he*" { # (--help) help text + send_user "USAGE: runtest \[options...\]\n" + send_user "\t--all (-a)\t\tPrint all test output to screen\n" + send_user "\t--baud (-ba)\t\tThe baud rate\n" + send_user "\t--build \[string\]\t\tThe canonical config name of the build machine\n" + send_user "\t--host \[string\]\t\tThe canonical config name of the host machine\n" + send_user "\t--target \[string\]\tThe canonical config name of the target board\n" + send_user "\t--connect (-co)\t\[type\]\tThe type of connection to use\n" + send_user "\t--debug (-de)\t\tSet expect debugging ON\n" + send_user "\t--help (-he)\t\tPrint help text\n" + send_user "\t--ignore \[name(s)\]\tThe names of specific tests to ignore\n" + send_user "\t--mail \[name(s)\]\tWho to mail the results to\n" + send_user "\t--name \[name\]\t\tThe hostname of the target board\n" + send_user "\t--objdir \[name\]\t\tThe test suite binary directory\n" + send_user "\t--outdir \[name\]\t\tThe directory to put logs in\n" + send_user "\t--reboot \[name\]\t\tReboot the target (if supported)\n" + send_user "\t--srcdir \[name\]\t\tThe test suite source code directory\n" + send_user "\t--strace \[number\]\tSet expect tracing ON\n" + send_user "\t--tool\[name(s)\]\t\tRun tests on these tools\n" + send_user "\t--verbose (-v)\t\tEmit verbose output\n" + send_user "\t--version (-V)\t\tEmit all version numbers\n" + send_user "\t--D\[0-1\]\t\tTcl debugger\n" + send_user "\tscript.exp\[=arg(s)\]\tRun these tests only\n" + send_user "\tMakefile style arguments can also be used, ex. CC=gcc\n\n" + exit 0 + } + + default { + send_error "\nIllegal Argument \"$option\"\n" + send_error "try \"runtest --help\" for option list\n" + exit 1 + } + + } +} + +# +# check for a few crucial variables +# +if ![info exists tool] { + send_error "WARNING: No tool specified\n" + set tool "" +} + +# +# initialize a few Tcl variables to something other than their default +# +if { $verbose > 2 } { + log_user 1 +} else { + log_user 0 +} + +set timeout 10 + +# +# load_lib -- load a library by sourcing it +# +# If there a multiple files with the same name, stop after the first one found. +# The order is first look in the install dir, then in a parallel dir in the +# source tree, (up one or two levels), then in the current dir. +# +proc load_lib { file } { + global verbose libdir srcdir base_dir execpath tool + + # ??? We could use `load_file' here but then we'd lose the "library file" + # specific text in verbose and error messages. Worth it? + set found 0 + foreach dir "$libdir $libdir/lib [file dirname [file dirname $srcdir]]/bluegnu/lib $srcdir/lib . [file dirname [file dirname [file dirname $srcdir]]]/bluegnu/lib" { + verbose "Looking for library file $dir/$file" 2 + if [file exists $dir/$file] { + set found 1 + verbose "Loading library file $dir/$file" + if { [catch "uplevel #0 source $dir/$file"] == 1 } { + send_error "ERROR: tcl error sourcing library file $dir/$file.\n" + global errorInfo + if [info exists errorInfo] { + send_error "$errorInfo\n" + } + exit 1 + } + break + } + } + if { $found == 0 } { + send_error "ERROR: Couldn't find library file $file.\n" + exit 1 + } +} + +# +# load the testing framework libraries +# +load_lib utils.exp +load_lib framework.exp +load_lib debugger.exp +load_lib remote.exp +load_lib target.exp + +# +# open log files +# +open_logs + +# print the config info +clone_output "Test Run By $logname on [timestamp -format %c]" +if [is3way] { + clone_output "Target is $target_triplet" + clone_output "Host is $host_triplet" + clone_output "Build is $build_triplet" +} else { + if [isnative] { + clone_output "Native configuration is $target_triplet" + } else { + clone_output "Target is $target_triplet" + clone_output "Host is $host_triplet" + } +} + +clone_output "\n\t\t=== $tool tests ===\n" + +# +# Find the tool init file. This is in the config directory of the tool's +# testsuite directory. These used to all be named $target_abbrev-$tool.exp, +# but as the $tool variable goes away, it's now just $target_abbrev.exp. +# First we look for a file named with both the abbrev and the tool names. +# Then we look for one named with just the abbrev name. Finally, we look for +# a file called default, which is the default actions, as some tools could +# be purely host based. Unknown is mostly for error trapping. +# + +set found 0 +if ![info exists target_abbrev] { + set target_abbrev "unix" +} +foreach dir "${srcdir}/config ${srcdir}/../config ${srcdir}/../../config ${srcdir}/../../../config" { + foreach initfile "${target_abbrev}-${tool}.exp ${target_abbrev}.exp ${target_os}.exp default.exp unknown.exp" { + verbose "Looking for tool init file ${dir}/${initfile}" 2 + if [file exists ${dir}/${initfile}] { + set found 1 + verbose "Using ${dir}/${initfile} as tool init file." + if [catch "uplevel #0 source ${dir}/${initfile}"]==1 { + send_error "ERROR: tcl error sourcing tool init file ${dir}/${initfile}.\n" + if [info exists errorInfo] { + send_error "$errorInfo\n" + } + exit 1 + } + break + } + } + if $found { + break + } +} + +if { $found == 0 } { + send_error "ERROR: Couldn't find tool init file.\n" + exit 1 +} +unset found + +# +# Trap some signals so we know what's happening. These replace the previous +# ones because we've now loaded the library stuff. +# +if ![exp_debug] { + foreach sig "{SIGTERM {terminated}} \ + {SIGINT {interrupted by user}} \ + {SIGQUIT {interrupted by user}} \ + {SIGSEGV {segmentation violation}}" { + trap { send_error "Got a [trap -name] signal, [lindex $sig 1]\n"; \ + log_summary } [lindex $sig 0] + verbose "setting trap for [lindex $sig 0] to \"[lindex $sig 1]\"" 1 + } +} +unset sig + +# +# Setup for main test execution loop +# + +if [info exists errorInfo] { + unset errorInfo +} +reset_vars +# FIXME: The trailing '/' is deprecated and will go away at some point. +# Do not assume $srcdir has a trailing '/'. +append srcdir "/" +# make sure we have only single path delimiters +regsub -all "//*" $srcdir "/" srcdir + + +# If multiple passes requested, set them up. Otherwise prepare just one. +# The format of `MULTIPASS' is a list of elements containing +# "{ name var1=value1 ... }" where `name' is a generic name for the pass and +# currently has no other meaning. + +if { [info exists MULTIPASS] } { + set multipass $MULTIPASS +} +if { $multipass == "" } { + set multipass { "" } +} + +# Pass varaibale passed as arguments into the queue +# +foreach var $makevars { + if {[string compare $var "MULTIPASS"] != 0} { + appendQueue Q0 "./tools/setVariable.exp=$var=[set $var]" + } +} + +foreach pass $multipass { + # multipass_name is set for `record_test' to use (see framework.exp). + if { [lindex $pass 0] != "" } { + set multipass_name [lindex $pass 0] + clone_output "Running pass `$multipass_name' ..." + # Pass MULTIPASS into queue + appendQueue Q0 "./tools/setVariable.exp=MULTIPASS=$pass" + } else { + set multipass_name "" + } + set restore "" + foreach varval [lrange $pass 1 end] { + # FIXME: doesn't handle a=b=c. + set tmp [split $varval "="] + set var [lindex $tmp 0] + # Save previous value. + if [info exists $var] { + lappend restore "$var [list [eval concat \$$var]]" + } else { + lappend restore "$var" + } + # Handle "CFLAGS=$CFLAGS foo". + # FIXME: Do we need to `catch' this? + eval set $var \[concat [lindex $tmp 1]\] + verbose "$var is now [eval concat \$$var]" + unset tmp var + } + + # look for the top level testsuites. if $tool doesn't + # exist and there are no subdirectories in $srcdir, then + # we default to srcdir. + set test_top_dirs [lsort [getdirs ${srcdir} "$tool*"]] + if { ${test_top_dirs} == "" } { + set test_top_dirs ${srcdir} + } + verbose "Top level testsuite dirs are ${test_top_dirs}" 2 + foreach dir "${test_top_dirs}" { + foreach test_name [lsort [find ${dir} *.exp]] { + if { ${test_name} == "" } { + continue + } + # Ignore this one if asked to. + if ![string match "" ${ignoretests}] { + if { 0 <= [lsearch ${ignoretests} [file tail ${test_name}]]} { + continue + } + } + # Get the path after the $srcdir so we know the subdir we're in. + set subdir "" + regsub $srcdir [file dirname $test_name] "" subdir + if { "$srcdir" == "$subdir/" } { + set subdir "" + } + # Check to see if the range of tests is limited, + # set `runtests' to a list of two elements: the script name + # and any arguments ("" if none). + if { [array size all_runtests] > 0 } { + if { 0 > [lsearch [array names all_runtests] [file tail $test_name]]} { + continue + } + set runtests [list [file tail $test_name] $all_runtests([file tail $test_name])] + } else { + set runtests [list [file tail $test_name] ""] + } + clone_output "Running $test_name ..." + #################################################### + # + # Append test to queue + # + if {[string length [lindex $runtests 1]] == 0} { + appendQueue Q0 $test_name + } else { + appendQueue Q0 [join [list $test_name \ + [lindex $runtests 1]] "="] + } + # + #################################################### + } + } + + # Restore the variables set by this pass. + foreach varval $restore { + if { [llength $varval] > 1 } { + verbose "Restoring [lindex $varval 0] to [lindex $varval 1]" 4 + set [lindex $varval 0] [lindex $varval 1] + } else { + verbose "Restoring [lindex $varval 0] to `unset'" 4 + unset [lindex $varval 0] + } + } +} +# +# do quite a bit of cleaning +# +unset restore i +unset ignoretests +foreach var $makevars { + unset $var +} +catch {unset tmp} +catch {unset makevars} +catch {unset pass} +catch {unset multipass} +catch {unset var} +catch {unset varval} +puts "======= DejaGnu" diff --git a/contrib/bluegnu2.0.3/lib/dg.exp b/contrib/bluegnu2.0.3/lib/dg.exp new file mode 100644 index 0000000..64b3e32 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/dg.exp @@ -0,0 +1,881 @@ +# `dg' general purpose testcase driver. +# Copyright (C) 1994, 1995, 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, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# dje@cygnus.com. + +# This file was written by Doug Evans (dje@cygnus.com). + +# This file is based on old-dejagnu.exp. It is intended to be more extensible +# without incurring the overhead that old-dejagnu.exp can. All test framework +# commands appear in the testcase as "{ dg-xxx args ... }". We pull them out +# with one grep, and then run the function(s) named by "dg-xxx". When running +# dg-xxx, the line number that it occurs on is always passed as the first +# argument. We also support different kinds of tools via callbacks. +# +# The currently supported options are: +# +# dg-prms-id N +# set prms_id to N +# +# dg-options "options ..." [{ target selector }] +# specify special options to pass to the tool (eg: compiler) +# +# dg-do do-what-keyword [{ target/xfail selector }] +# `do-what-keyword' is tool specific and is passed unchanged to +# ${tool}-dg-test. An example is gcc where `keyword' can be any of: +# preprocess|compile|assemble|link|run +# and will do one of: produce a .i, produce a .s, produce a .o, +# produce an a.out, or produce an a.out and run it (the default is +# compile). +# +# dg-error regexp comment [{ target/xfail selector } [{.|0|linenum}]] +# indicate an error message <regexp> is expected on this line +# (the test fails if it doesn't occur) +# Linenum=0 for general tool messages (eg: -V arg missing). +# "." means the current line. +# +# dg-warning regexp comment [{ target/xfail selector } [{.|0|linenum}]] +# indicate a warning message <regexp> is expected on this line +# (the test fails if it doesn't occur) +# +# dg-bogus regexp comment [{ target/xfail selector } [{.|0|linenum}]] +# indicate a bogus error message <regexp> use to occur here +# (the test fails if it does occur) +# +# dg-build regexp comment [{ target/xfail selector }] +# indicate the build use to fail for some reason +# (errors covered here include bad assembler generated, tool crashes, +# and link failures) +# (the test fails if it does occur) +# +# dg-excess-errors comment [{ target/xfail selector }] +# indicate excess errors are expected (any line) +# (this should only be used sparingly and temporarily) +# +# dg-output regexp [{ target selector }] +# indicate the expected output of the program is <regexp> +# (there may be multiple occurrences of this, they are concatenated) +# +# dg-final { tcl code } +# add some tcl code to be run at the end +# (there may be multiple occurrences of this, they are concatenated) +# (unbalanced braces must be \-escaped) +# +# "{ target selector }" is a list of expressions that determine whether the +# test succeeds or fails for a particular target, or in some cases whether the +# option applies for a particular target. If the case of `dg-do' it specifies +# whether the testcase is even attempted on the specified target. +# +# The target selector is always optional. The format is one of: +# +# { xfail *-*-* ... } - the test is expected to fail for the given targets +# { target *-*-* ... } - the option only applies to the given targets +# +# At least one target must be specified, use *-*-* for "all targets". +# At present it is not possible to specify both `xfail' and `target'. +# "native" may be used in place of "*-*-*". +# +# Example: +# +# [ ... some complicated code ... ] +# return a; /* { dg-build "fatal" "ran out of spill regs" { xfail i386-*-* } } */ +# +# In this example, the compiler use to crash on the "return a;" for some +# target and that it still does crash on i386-*-*. Admittedly, this is a +# contrived example. +# +# ??? It might be possible to add additional optional arguments by having +# something like: { dg-error ".*syntax.*" "syntax error" { { foo 1 } ... } } +# +# Callbacks +# +# ${tool}-dg-test testfile do-what-keyword extra-flags +# +# Run the test, be it compiler, assembler, or whatever. +# +# ${tool}-dg-prune target_triplet text +# +# Optional callback to delete output from the tool that can occur +# even in successful ("pass") situations and interfere with output +# pattern matching. This also gives the tool an opportunity to review +# the output and check for any conditions which indicate an "untested" +# or "unresolved" state. An example is if a testcase is too big and +# fills all available ram (which can happen for 16 bit cpus). The +# result is either the pruned text or +# "::untested|unresolved|unsupported::message" +# (eg: "::unsupported::memory full"). +# +# Notes: +# 1) All runnable testcases must return 0 from main() for success. +# You can't rely on getting any return code from target boards, and the +# `exec' command says a program fails if it returns non-zero. +# +# Language independence is (theoretically) achieved by: +# +# 1) Using global $tool to indicate the language (eg: gcc, g++, gas, etc.). +# This should only be used to look up other objects. We don't want to +# have to add code for each new language that is supported. If this is +# done right, no code needs to be added here for each new language. +# +# 2) Passing tool options in as arguments. +# +# Earlier versions of ${tool}_start (eg: gcc_start) would only take the name +# of the file to compile as an argument. Newer versions accept a list of +# one or two elements, the second being a string of *all* options to pass +# to the tool. We require this facility. +# +# 3) Callbacks. +# +# Try not to do anything else that makes life difficult. +# +# The normal way to write a testsuite is to have a .exp file containing: +# +# load_lib ${tool}-dg.exp +# dg-init +# dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/foo*]] ... +# dg-finish + +# Global state variables. +# The defaults are for GCC. + +# The default do-what keyword. +set dg-do-what-default compile + +# When dg-interpreter-batch-mode is 1, no execution test or excess error +# tests are performed. +set dg-interpreter-batch-mode 0 + +# Line number format. This is how line numbers appear in program output. +set dg-linenum-format ":%d:" +proc dg-format-linenum { linenum } { + global dg-linenum-format + return [format ${dg-linenum-format} $linenum] +} + +# Useful subroutines. + +# dg-get-options -- pick out the dg-xxx options in a testcase +# +# PROG is the file name of the testcase. +# The result is a list of options found. +# +# Example: For the following testcase: +# +# /* { dg-prms-id 1234 } */ +# int foo { return 0; } /* { dg-build fatal "some comment" } */ +# +# we return: +# +# { dg-prms-id 1 1234 } { dg-build 2 fatal "some comment" } + +proc dg-get-options { prog } { + set result "" + + set tmp [grep $prog "{\[ \t\]\+dg-\[-a-z\]\+\[ \t\]\+.*\[ \t\]\+}" line] + if ![string match "" $tmp] { + foreach i $tmp { + #send_user "Found: $i\n" + # FIXME: When to use "+" and "\+" isn't clear. + # Seems to me it took awhile to get this to work. + regexp "(\[0-9\]\+)\[ \t\]\+{\[ \t\]+(dg-\[-a-z\]+)\[ \t\]\+(.*)\[ \t\]+}\[^\}\]*(\n|$)" $i i line cmd args + #send_user "Found: $cmd $line $args\n" + append result " { $cmd $line $args }" + } + } + + #send_user "Returning: $result\n" + return $result +} + +# +# Process optional xfail/target arguments +# +# SELECTOR is "xfail target-triplet-1 ..." or "target target-triplet-1 ..." +# `target-triplet' may be "native". +# For xfail, the result is "F" (expected to Fail) if the current target is +# affected, otherwise "P" (expected to Pass). +# For target, the result is "S" (target is Selected) if the target is selected, +# otherwise "N" (target is Not selected). +# +proc dg-process-target { selector } { + global target_triplet + + set isnative [isnative] + set triplet_match 0 + + #send_user "dg-process-target: $selector\n" + + set selector [string trim $selector] + if [regexp "^xfail " $selector] { + set what xfail + } elseif [regexp "^target " $selector] { + set what target + } else { + # The use of error here and in other dg-xxx utilities is intentional. + # dg-test will catch them and do the right thing. + error "syntax error in target selector \"$selector\"" + } + + # ??? This should work but it doesn't. tcl bug? + #if [regexp "^${what}(( \[^ \]+-\[^ \]+-\[^ \]+)|( native))+$" $selector tmp selector] + if [regexp "^${what}( \[^ \]+-\[^ \]+-\[^ \]+| native)+$" $selector] { + regsub "^${what} " $selector "" selector + #send_user "selector: $selector\n" + foreach triplet $selector { + if [string match $triplet $target_triplet] { + set triplet_match 1 + } elseif { $isnative && $triplet == "native" } { + set triplet_match 1 + } + } + } else { + error "syntax error in target selector \"$selector\"" + } + + if { $triplet_match } { + return [expr { $what == "xfail" ? "F" : "S" }] + } else { + return [expr { $what == "xfail" ? "P" : "N" }] + } +} + +# Predefined user option handlers. +# The line number is always the first element. +# Note that each of these are varargs procs (they have an `args' argument). +# Tests for optional arguments are coded with ">=" to simplify adding new ones. + +proc dg-prms-id { args } { + global prms_id ;# this is a testing framework variable + + if { [llength $args] > 2 } { + error "[lindex $args 0]: too many arguments" + return + } + + set prms_id [lindex $args 1] +} + +# +# Set tool options +# +# Different options can be used for different targets by having multiple +# instances, selecting a different target each time. Since options are +# processed in order, put the default value first. Subsequent occurrences +# will override previous ones. +# + +proc dg-options { args } { + upvar dg-extra-tool-flags extra-tool-flags + + if { [llength $args] > 3 } { + error "[lindex $args 0]: too many arguments" + return + } + + if { [llength $args] >= 3 } { + switch [dg-process-target [lindex $args 2]] { + "S" { set extra-tool-flags [lindex $args 1] } + "N" { } + "F" { error "[lindex $args 0]: `xfail' not allowed here" } + "P" { error "[lindex $args 0]: `xfail' not allowed here" } + } + } else { + set extra-tool-flags [lindex $args 1] + } +} + +# +# Record what to do (compile/run/etc.) +# +# Multiple instances are supported (since we don't support target and xfail +# selectors on one line), though it doesn't make much sense to change the +# compile/assemble/link/run field. Nor does it make any sense to have +# multiple lines of target selectors (use one line). +# +proc dg-do { args } { + upvar dg-do-what do-what + + if { [llength $args] > 3 } { + error "[lindex $args 0]: too many arguments" + return + } + + set selected [lindex ${do-what} 1] ;# selected? (""/S/N) + set expected [lindex ${do-what} 2] ;# expected to pass/fail (P/F) + + if { [llength $args] >= 3 } { + switch [dg-process-target [lindex $args 2]] { + "S" { + set selected "S" + } + "N" { + # Don't deselect a target if it's been explicitly selected, + # but indicate a specific target has been selected (so don't + # do this testcase if it's not appropriate for this target). + # The user really shouldn't have multiple lines of target + # selectors, but try to do the intuitive thing (multiple lines + # are OR'd together). + if { $selected != "S" } { + set selected "N" + } + } + "F" { set expected "F" } + "P" { + # There's nothing to do for "P". We don't want to clobber a + # previous xfail for this target. + } + } + } else { + # Note: A previous occurrence of `dg-do' with target/xfail selectors + # is a user mistake. We clobber previous values here. + set selected S + set expected P + } + + switch [lindex $args 1] { + "preprocess" { } + "compile" { } + "assemble" { } + "link" { } + "run" { } + default { + error "[lindex $args 0]: syntax error" + } + } + set do-what [list [lindex $args 1] $selected $expected] +} + +proc dg-error { args } { + upvar dg-messages messages + + if { [llength $args] > 5 } { + error "[lindex $args 0]: too many arguments" + return + } + + set xfail "" + if { [llength $args] >= 4 } { + switch [dg-process-target [lindex $args 3]] { + "F" { set xfail "X" } + "P" { set xfail "" } + "N" { + # If we get "N", this error doesn't apply to us so ignore it. + return + } + } + } + + if { [llength $args] >= 5 } { + switch [lindex $args 4] { + "." { set line [dg-format-linenum [lindex $args 0]] } + "0" { set line "" } + "default" { set line [dg-format-linenum [lindex $args 4]] } + } + } else { + set line [dg-format-linenum [lindex $args 0]] + } + + lappend messages [list $line "${xfail}ERROR" [lindex $args 1] [lindex $args 2]] +} + +proc dg-warning { args } { + upvar dg-messages messages + + if { [llength $args] > 5 } { + error "[lindex $args 0]: too many arguments" + return + } + + set xfail "" + if { [llength $args] >= 4 } { + switch [dg-process-target [lindex $args 3]] { + "F" { set xfail "X" } + "P" { set xfail "" } + "N" { + # If we get "N", this warning doesn't apply to us so ignore it. + return + } + } + } + + if { [llength $args] >= 5 } { + switch [lindex $args 4] { + "." { set line [dg-format-linenum [lindex $args 0]] } + "0" { set line "" } + "default" { set line [dg-format-linenum [lindex $args 4]] } + } + } else { + set line [dg-format-linenum [lindex $args 0]] + } + + lappend messages [list $line "${xfail}WARNING" [lindex $args 1] [lindex $args 2]] +} + +proc dg-bogus { args } { + upvar dg-messages messages + + if { [llength $args] > 5 } { + error "[lindex $args 0]: too many arguments" + return + } + + set xfail "" + if { [llength $args] >= 4 } { + switch [dg-process-target [lindex $args 3]] { + "F" { set xfail "X" } + "P" { set xfail "" } + "N" { + # If we get "N", this message doesn't apply to us so ignore it. + return + } + } + } + + if { [llength $args] >= 5 } { + switch [lindex $args 4] { + "." { set line [dg-format-linenum [lindex $args 0]] } + "0" { set line "" } + "default" { set line [dg-format-linenum [lindex $args 4]] } + } + } else { + set line [dg-format-linenum [lindex $args 0]] + } + + lappend messages [list $line "${xfail}BOGUS" [lindex $args 1] [lindex $args 2]] +} + +proc dg-build { args } { + upvar dg-messages messages + + if { [llength $args] > 4 } { + error "[lindex $args 0]: too many arguments" + return + } + + set xfail "" + if { [ llength $args] >= 4 } { + switch [dg-process-target [lindex $args 3]] { + "F" { set xfail "X" } + "P" { set xfail "" } + "N" { + # If we get "N", this lossage doesn't apply to us so ignore it. + return + } + } + } + + lappend messages [list [lindex $args 0] "${xfail}BUILD" [lindex $args 1] [lindex $args 2]] +} + +proc dg-excess-errors { args } { + upvar dg-excess-errors-flag excess-errors-flag + + if { [llength $args] > 3 } { + error "[lindex $args 0]: too many arguments" + return + } + + if { [llength $args] >= 3 } { + switch [dg-process-target [lindex $args 2]] { + "F" { set excess-errors-flag 1 } + "S" { set excess-errors-flag 1 } + } + } else { + set excess-errors-flag 1 + } +} + +# +# Indicate expected program output +# +# We support multiple occurrences, but we do not implicitly insert newlines +# between them. +# +# Note that target boards don't all support this kind of thing so it's a good +# idea to specify the target all the time. If one or more targets are +# explicitly selected, the test won't be performed if we're not one of them +# (as long as we were never mentioned). +# +# If you have target dependent output and want to set an xfail for one or more +# of them, use { dg-output "" { xfail a-b-c ... } }. The "" won't contribute +# to the expected output. +# +proc dg-output { args } { + upvar dg-output-text output-text + + if { [llength $args] > 3 } { + error "[lindex $args 0]: too many arguments" + return + } + + # Allow target dependent output. + + set expected [lindex ${output-text} 0] + if { [llength $args] >= 3 } { + switch [dg-process-target [lindex $args 2]] { + "N" { return } + "S" { } + "F" { set expected "F" } + # Don't override a previous xfail. + "P" { } + } + } + + if { [llength ${output-text}] == 1 } { + # First occurrence. + set output-text [list $expected [lindex $args 1]] + } else { + set output-text [list $expected "[lindex ${output-text} 1][lindex $args 1]"] + } +} + +proc dg-final { args } { + upvar dg-final-code final-code + + if { [llength $args] > 2 } { + error "[lindex $args 0]: too many arguments" + return + } + + #send_user "dg-final: $args\n" + append final-code "[lindex $args 1]\n" +} + +# +# Set up our environment +# +# There currently isn't much to do, but always calling it allows us to add +# enhancements without having to update our callers. +# It must be run before calling `dg-test'. + +proc dg-init { } { + # If the tool has an "init" routine, call it. + global tool + if ![string match "" [info procs ${tool}_init]] { + ${tool}_init + } +} + +# dg-runtest -- simple main loop useful to most testsuites +# +# FLAGS is a set of options to always pass. +# DEFAULT_EXTRA_FLAGS is a set of options to pass if the testcase doesn't +# specify any (with dg-option). +# ??? We're flipping between "flag" and "option" here. + +proc dg-runtest { testcases flags default-extra-flags } { + global runtests + + foreach testcase $testcases { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $testcase] { + continue + } + verbose "Testing [file tail [file dirname $testcase]]/[file tail $testcase]" + dg-test $testcase $flags ${default-extra-flags} + } +} + +# +# Runs a new style DejaGnu test +# +# PROG is the full path name of the file to pass to the tool (eg: compiler). +# TOOL_FLAGS is a set of options to always pass. +# DEFAULT_EXTRA_TOOL_FLAGS are additional options if the testcase has none. + +proc dg-test { prog tool_flags default_extra_tool_flags } { + global dg-do-what-default dg-interpreter-batch-mode dg-linenum-format + global errorCode errorInfo + global comp_output exec_output + global tool + global srcdir ;# eg: /calvin/dje/devo/gcc/./testsuite/ + global host_triplet target_triplet + + set text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]*" + + regsub "^$srcdir/?" $prog "" name + # If we couldn't rip $srcdir out of `prog' then just do the best we can. + # The point is to reduce the unnecessary noise in the logs. Don't strip + # out too much because different testcases with the same name can confuse + # `test-tool'. + if [string match "/*" $name] { + set name "[file tail [file dirname $prog]]/[file tail $prog]" + } + + # Process any embedded dg options in the testcase. + + # Use "" for the second element of dg-do-what so we can tell if it's been + # explicitly set to "S". + set dg-do-what [list ${dg-do-what-default} "" P] + set dg-excess-errors-flag 0 + set dg-messages "" + set dg-extra-tool-flags $default_extra_tool_flags + set dg-final-code "" + + # `dg-output-text' is a list of two elements: pass/fail and text. + # Leave second element off for now (indicates "don't perform test") + set dg-output-text "P" + + # Define our own "special function" `unknown' so we catch spelling errors. + # But first rename the existing one so we can restore it afterwards. + catch {rename dg-save-unknown ""} + rename unknown dg-save-unknown + proc unknown { args } { + return -code error "unknown dg option: $args" + } + + set tmp [dg-get-options $prog] + foreach op $tmp { + verbose "Processing option: $op" 3 + set status [catch "$op" errmsg] + if { $status != 0 } { + if { 0 && [info exists errorInfo] } { + # This also prints a backtrace which will just confuse + # testcase writers, so it's disabled. + perror "$name: $errorInfo\n" + } else { + perror "$name: $errmsg for \"$op\"\n" + } + # ??? The call to unresolved here is necessary to clear `errcnt'. + # What we really need is a proc like perror that doesn't set errcnt. + # It should also set exit_status to 1. + unresolved "$name: $errmsg for \"$op\"" + return + } + } + + # Restore normal error handling. + rename unknown "" + rename dg-save-unknown unknown + + # If we're not supposed to try this test on this target, we're done. + if { [lindex ${dg-do-what} 1] == "N" } { + unsupported "$name" + verbose "$name not supported on this target, skipping it" 3 + return + } + + # Run the tool and analyze the results. + # The result of ${tool}-dg-test is in a bit of flux. + # Currently it is the name of the output file (or "" if none). + # If we need more than this it will grow into a list of things. + # No intention is made (at this point) to preserve upward compatibility + # (though at some point we'll have to). + + set output_file [${tool}-dg-test $prog [lindex ${dg-do-what} 0] "$tool_flags ${dg-extra-tool-flags}"] + + #send_user "\nold_dejagnu.exp: comp_output1 = :$comp_output:\n\n" + #send_user "\nold_dejagnu.exp: message = :$message:\n\n" + #send_user "\nold_dejagnu.exp: message length = [llength $message]\n\n" + + foreach i ${dg-messages} { + verbose "Scanning for message: $i" 4 + + # Remove all error messages for the line [lindex $i 0] + # in the source file. If we find any, success! + set line [lindex $i 0] + set pattern [lindex $i 2] + set comment [lindex $i 3] + #send_user "Before:\n$comp_output\n" + if [regsub -all "(^|\n)(\[^\n\]+$line\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output] { + set comp_output [string trimleft $comp_output] + set ok pass + set uhoh fail + } else { + set ok fail + set uhoh pass + } + #send_user "After:\n$comp_output\n" + + # $line will either be a formatted line number or a number all by + # itself. Delete the formatting. + scan $line ${dg-linenum-format} line + switch [lindex $i 1] { + "ERROR" { + $ok "$name $comment (test for errors, line $line)" + } + "XERROR" { + x$ok "$name $comment (test for errors, line $line)" + } + "WARNING" { + $ok "$name $comment (test for warnings, line $line)" + } + "XWARNING" { + x$ok "$name $comment (test for warnings, line $line)" + } + "BOGUS" { + $uhoh "$name $comment (test for bogus messages, line $line)" + } + "XBOGUS" { + x$uhoh "$name $comment (test for bogus messages, line $line)" + } + "BUILD" { + $uhoh "$name $comment (test for build failure, line $line)" + } + "XBUILD" { + x$uhoh "$name $comment (test for build failure, line $line)" + } + "EXEC" { } + "XEXEC" { } + } + #send_user "\nold_dejagnu.exp: comp_output2= :$comp_output:\n\n" + } + #send_user "\nold_dejagnu.exp: comp_output3 = :$comp_output:\n\n" + + # Remove messages from the tool that we can ignore. + #send_user "comp_output: $comp_output\n" + set comp_output [prune_system_crud $host_triplet $comp_output] + + if { [info proc ${tool}-dg-prune] != "" } { + set comp_output [${tool}-dg-prune $target_triplet $comp_output] + switch -glob $comp_output { + "::untested::*" { + regsub "::untested::" $comp_output "" message + untested "$name: $message" + return + } + "::unresolved::*" { + regsub "::unresolved::" $comp_output "" message + unresolved "$name: $message" + return + } + "::unsupported::*" { + regsub "::unsupported::" $comp_output "" message + unsupported "$name: $message" + return + } + } + } + + # See if someone forgot to delete the extra lines. + regsub -all "\n+" $comp_output "\n" comp_output + regsub "^\n+" $comp_output "" comp_output + #send_user "comp_output: $comp_output\n" + + # Don't do this if we're testing an interpreter. + # FIXME: why? + if { ${dg-interpreter-batch-mode} == 0 } { + # Catch excess errors (new bugs or incomplete testcases). + if ${dg-excess-errors-flag} { + setup_xfail "*-*-*" + } + if ![string match "" $comp_output] { + fail "$name (test for excess errors)" + send_log "Excess errors:\n$comp_output\n" + } else { + pass "$name (test for excess errors)" + } + } + + # Run the executable image if asked to do so. + # FIXME: This is the only place where we assume a standard meaning to + # the `keyword' argument of dg-do. This could be cleaned up. + if { [lindex ${dg-do-what} 0] == "run" } { + if ![file exists $output_file] { + warning "$name compilation failed to produce executable" + } else { + set status -1 + set status [${tool}_load $output_file] + #send_user "After exec, status: $status\n" + if { [lindex ${dg-do-what} 2] == "F" } { + setup_xfail "*-*-*" + } + if { "$status" == "pass" } { + pass "$name execution test" + verbose "Exec succeeded." 3 + if { [llength ${dg-output-text}] > 1 } { + #send_user "${dg-output-text}\n" + if { [lindex ${dg-output-text} 0] == "F" } { + setup_xfail "*-*-*" + } + set texttmp [lindex ${dg-output-text} 1] + if { ![regexp $texttmp ${exec_output}] } { + fail "$name output pattern test, is ${exec_output}, should match $texttmp" + verbose "Failed test for output pattern $texttmp" 3 + } else { + pass "$name output pattern test, $texttmp" + verbose "Passed test for output pattern $texttmp" 3 + } + unset texttmp + } + } elseif { "$status" == "fail" } { + # It would be nice to get some info out of errorCode. + if [info exists errorCode] { + verbose "Exec failed, errorCode: $errorCode" 3 + } else { + verbose "Exec failed, errorCode not defined!" 3 + } + fail "$name execution test" + } else { + $status "$name execution test" + } + } + } + + # Are there any further tests to perform? + # Note that if the program has special run-time requirements, running + # of the program can be delayed until here. Ditto for other situations. + # It would be a bit cumbersome though. + + if ![string match ${dg-final-code} ""] { + regsub -all "\\\\(\[{}\])" ${dg-final-code} "\\1" dg-final-code + # Note that the use of `args' here makes this a varargs proc. + proc dg-final-proc { args } ${dg-final-code} + verbose "Running dg-final tests." 3 + verbose "dg-final-proc:\n[info body dg-final-proc]" 4 + if [catch "dg-final-proc $prog" errmsg] { + perror "$name: error executing dg-final: $errmsg" + # ??? The call to unresolved here is necessary to clear `errcnt'. + # What we really need is a proc like perror that doesn't set errcnt. + # It should also set exit_status to 1. + unresolved "$name: error executing dg-final: $errmsg" + } + } + + # Do some final clean up. + # When testing an interpreter, we don't compile something and leave an + # output file. + if { ${dg-interpreter-batch-mode} == 0 } { + catch "exec rm -f $output_file" + } +} + +# +# Do any necessary cleanups +# +# This is called at the end to undo anything dg-init did (that needs undoing). +# +proc dg-finish { } { + # Reset this in case caller wonders whether s/he should. + global prms_id + set prms_id 0 + + # The framework doesn't like to see any error remnants, so remove them. + global errorInfo + if [info exists errorInfo] { + unset errorInfo + } + + # If the tool has a "finish" routine, call it. + # There may be a bit of duplication (eg: resetting prms_id), leave it. + # Let's keep these procs robust. + global tool + if ![string match "" [info procs ${tool}_finish]] { + ${tool}_finish + } +} diff --git a/contrib/bluegnu2.0.3/lib/foo.itcl b/contrib/bluegnu2.0.3/lib/foo.itcl new file mode 100644 index 0000000..cd2c6f0 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/foo.itcl @@ -0,0 +1,21 @@ + +source lib/testSessionClasses.itcl +source lib/testSessionFramework.itcl +source lib/testSessionUtils.itcl + + +namespace TestSession { + Environment E0 + + #E0 saveEnv + E0 clearEnv + puts [join [E0 <<] "\n"] + + exit + + foreach obj [info objects] { + puts "$obj - [$obj <<]" + } +} + +::TestSession::clone_output "ERROR: testing" diff --git a/contrib/bluegnu2.0.3/lib/framework.exp b/contrib/bluegnu2.0.3/lib/framework.exp new file mode 100644 index 0000000..2018c4a --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/framework.exp @@ -0,0 +1,677 @@ +# 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 variables are local to this file. +# This or more warnings and a test fails. +set warning_threshold 3 +# This or more errors and a test fails. +set perror_threshold 1 + +proc mail_file { file to subject } { + if [file readable $file] { + catch "exec mail -s \"$subject\" $to < $file" + } +} + +# +# Open the output logs +# +proc open_logs { } { + global outdir + global tool + global sum_file + + if { ${tool} == "" } { + set tool testrun + } + catch "exec rm -f $outdir/$tool.sum" + set sum_file [open "$outdir/$tool.sum" w] + catch "exec rm -f $outdir/$tool.log" + log_file -a "$outdir/$tool.log" + verbose "Opening log files in $outdir" + if { ${tool} == "testrun" } { + set tool "" + } +} + + +# +# Close the output logs +# +proc close_logs { } { + global sum_file + + catch "close $sum_file" +} + +# +# Check build host triplet for pattern +# +# With no arguments it returns the triplet string. +# +proc isbuild { args } { + global build_triplet + global host_triplet + + if ![info exists build_triplet] { + set build_triplet ${host_triplet} + } + if [string match "" $args] { + return $build_triplet + } + verbose "Checking pattern \"$args\" with $build_triplet" 2 + + if [string match "$args" $build_triplet] { + return 1 + } else { + return 0 + } +} + +# +# If this is a canadian (3 way) cross. This means the tools are +# being built with a cross compiler for another host. +# +proc is3way {} { + global host_triplet + global build_triplet + + if ![info exists build_triplet] { + set build_triplet ${host_triplet} + } + verbose "Checking $host_triplet against $build_triplet" 2 + if { "$build_triplet" == "$host_triplet" } { + return 0 + } + return 1 +} + +# +# Check host triplet for pattern +# +# With no arguments it returns the triplet string. +# +proc ishost { args } { + global host_triplet + + if [string match "" $args] { + return $host_triplet + } + verbose "Checking pattern \"$args\" with $host_triplet" 2 + + if [string match "$args" $host_triplet] { + return 1 + } else { + return 0 + } +} + +# +# Check target triplet for pattern +# +# With no arguments it returns the triplet string. +# Returns 1 if the target looked for, or 0 if not. +# +proc istarget { args } { + global target_triplet + + # if no arg, return the config string + if [string match "" $args] { + if [info exists target_triplet] { + return $target_triplet + } else { + perror "No target configuration names found." + } + } + + # now check against the cannonical name + if [info exists target_triplet] { + verbose "Checking \"$args\" against \"$target_triplet\"" 2 + if [string match "$args" $target_triplet] { + return 1 + } + } + + # nope, no match + return 0 +} + +# +# Check to see if we're running the tests in a native environment +# +# Returns 1 if running native, 0 if on a target. +# +proc isnative { } { + global target_triplet + global build_triplet + + if [string match $build_triplet $target_triplet] { + return 1 + } + return 0 +} + +# +# unknown -- called by expect if a proc is called that doesn't exist +# +proc unknown { args } { + global errorCode + global errorInfo + + clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist." + if [info exists errorCode] { + send_error "The error code is $errorCode\n" + } + if [info exists errorInfo] { + send_error "The info on the error is:\n$errorInfo\n" + } + + log_summary +} + +# +# Print output to stdout (or stderr) and to log file +# +# If the --all flag (-a) option was used then all messages go the the screen. +# Without this, all messages that start with a keyword are written only to the +# detail log file. All messages that go to the screen will also appear in the +# detail log. This should only be used by the framework itself using pass, +# fail, xpass, xfail, warning, perror, note, untested, unresolved, or +# unsupported procedures. +# +proc clone_output { message } { + global sum_file + global all_flag + + puts $sum_file "$message" + case [lindex $message 0] in { + {"PASS:" "XFAIL:" "UNRESOLVED:" "UNSUPPORTED:" "UNTESTED:"} { + if $all_flag { + send_user "$message\n" + return "$message" + } else { + send_log "$message\n" + } + } + {"ERROR:" "WARNING:" "NOTE:"} { + send_error "$message\n" + return "$message" + } + default { + send_user "$message\n" + return "$message" + } + } +} + +# +# Reset all globally used variables +# +proc reset_vars {} { + # test result counters + global testcnt + global failcnt + global passcnt + global xfailcnt + global xpasscnt + global untestedcnt + global unresolvedcnt + global unsupportedcnt + + # other miscellaneous variables + global prms_id + global bug_id + + # reset them all + set prms_id 0 + set bug_id 0 + set testcnt 0 + set failcnt 0 + set passcnt 0 + set xfailcnt 0 + set xpasscnt 0 + set untestedcnt 0 + set unresolvedcnt 0 + set unsupportedcnt 0 + + # Variables local to this file. + global warning_threshold perror_threshold + set warning_threshold 3 + set perror_threshold 1 +} + +# +# Print summary of all pass/fail counts +# +# Calling this exits. +# +proc log_summary {} { + global tool + global sum_file + global exit_status + global failcnt + global passcnt + global testcnt + global xfailcnt + global xpasscnt + global untestedcnt + global unresolvedcnt + global unsupportedcnt + global mail_logs + global outdir + global mailing_list + + clone_output "\n\t\t=== $tool Summary ===\n" + + # If the tool set `testcnt', it wants us to do a sanity check on the + # total count, so compare the reported number of testcases with the + # expected number. Maintaining an accurate count in `testcnt' isn't easy + # so it's not clear how often this will be used. + if { $testcnt > 0 } { + # total all the testcases reported + set totlcnt [expr $failcnt+$passcnt+$xfailcnt+$xpasscnt] + set totlcnt [expr $totlcnt+$untestedcnt+$unresolvedcnt+$unsupportedcnt] + + if { $testcnt>$totlcnt || $testcnt<$totlcnt } { + if { $testcnt > $totlcnt } { + set mismatch "unreported [expr $testcnt-$totlcnt]" + } + if { $testcnt < $totlcnt } { + set mismatch "misreported [expr $totlcnt-$testcnt]" + } + } else { + verbose "# of testcases run $testcnt" + } + + if [info exists mismatch] { + clone_output "### ERROR: totals do not equal number of testcases run" + clone_output "### ERROR: # of testcases expected $testcnt" + clone_output "### ERROR: # of testcases reported $totlcnt" + clone_output "### ERROR: # of testcases $mismatch\n" + } + } + + if { $passcnt > 0 } { + clone_output "# of expected passes $passcnt" + } + if { $xfailcnt > 0 } { + clone_output "# of expected failures $xfailcnt" + } + if { $xpasscnt > 0 } { + clone_output "# of unexpected successes $xpasscnt" + } + if { $failcnt > 0 } { + clone_output "# of unexpected failures $failcnt" + } + if { $unresolvedcnt > 0 } { + clone_output "# of unresolved testcases $unresolvedcnt" + } + if { $untestedcnt > 0 } { + clone_output "# of untested testcases $untestedcnt" + } + if { $unsupportedcnt > 0 } { + clone_output "# of unsupported tests $unsupportedcnt" + } + # extract version number + if {[info procs ${tool}_version] != ""} { + if {[catch "${tool}_version" output]} { + warning "${tool}_version failed:\n$output" + } + } + close_logs + cleanup + if $mail_logs { + mail_file $outdir/$tool.sum $mailing_list "Dejagnu Summary Log" + } + exit $exit_status +} + +# +# Close all open files, remove temp file and core files +# +proc cleanup {} { + global sum_file + global exit_status + global done_list + global base_dir + global subdir + + #catch "exec rm -f [glob xgdb core *.x *.o *_soc a.out]" + #catch "exec rm -f [glob -nocomplain $subdir/*.o $subdir/*.x $subdir/*_soc]" +} + +# +# Setup a flag to control whether a failure is expected or not +# +# Multiple target triplet patterns can be specified for targets +# for which the test fails. A decimal number can be specified, +# which is the PRMS number. +# +proc setup_xfail { args } { + global xfail_flag + global xfail_prms + + set xfail_prms 0 + set argc [ llength $args ] + for { set i 0 } { $i < $argc } { incr i } { + set sub_arg [ lindex $args $i ] + # is a prms number. we assume this is a number with no characters + if [regexp "^\[0-9\]+$" $sub_arg] { + set xfail_prms $sub_arg + continue + } + if [istarget $sub_arg] { + set xfail_flag 1 + continue + } + } +} + +# +# Clear the xfail flag for a particular target +# +proc clear_xfail { args } { + global xfail_flag + global xfail_prms + + set argc [ llength $args ] + for { set i 0 } { $i < $argc } { incr i } { + set sub_arg [ lindex $args $i ] + case $sub_arg in { + "*-*-*" { # is a configuration triplet + if [istarget $sub_arg] { + set xfail_flag 0 + set xfail_prms 0 + } + continue + } + } + } +} + +# +# Record that a test has passed or failed (perhaps unexpectedly) +# +# This is an internal procedure, only used in this file. +# +proc record_test { type message } { + global passcnt failcnt xpasscnt xfailcnt + global untestedcnt unresolvedcnt unsupportedcnt + global exit_status + global prms_id bug_id + global xfail_flag xfail_prms + global errcnt warncnt + global warning_threshold perror_threshold + + # If we have too many warnings or errors, + # the output of the test can't be considered correct. + if { $warning_threshold > 0 && $warncnt >= $warning_threshold + || $perror_threshold > 0 && $errcnt >= $perror_threshold } { + # Reset these first to prevent infinite recursion. + set warncnt 0 + set errcnt 0 + unresolved $message + return + } + + switch $type { + PASS { + incr passcnt + if $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + FAIL { + incr failcnt + set exit_status 1 + if $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + XPASS { + incr xpasscnt + set exit_status 1 + if { $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } + } + XFAIL { + incr xfailcnt + if { $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } + } + UNTESTED { + incr untestedcnt + # The only reason we look at the xfail stuff is to pick up + # `xfail_prms'. + if { $xfail_flag && $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } elseif $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + UNRESOLVED { + incr unresolvedcnt + set exit_status 1 + # The only reason we look at the xfail stuff is to pick up + # `xfail_prms'. + if { $xfail_flag && $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } elseif $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + UNSUPPORTED { + incr unsupportedcnt + # The only reason we look at the xfail stuff is to pick up + # `xfail_prms'. + if { $xfail_flag && $xfail_prms != 0 } { + set message [concat $message "\t(PRMS $xfail_prms)"] + } elseif $prms_id { + set message [concat $message "\t(PRMS $prms_id)"] + } + } + default { + perror "record_test called with bad type `$type'" + set errcnt 0 + return + } + } + + if $bug_id { + set message [concat $message "\t(BUG $bug_id)"] + } + + global multipass_name + if { $multipass_name != "" } { + clone_output "$type: $multipass_name: $message" + } else { + clone_output "$type: $message" + } + + # Reset these so they're ready for the next test case. We don't reset + # prms_id or bug_id here. There may be multiple tests for them. Instead + # they are reset in the main loop after each test. It is also the + # testsuite driver's responsibility to reset them after each testcase. + set warncnt 0 + set errcnt 0 + set xfail_flag 0 + set xfail_prms 0 +} + +# +# Record that a test has passed +# +proc pass { message } { + global xfail_flag + + if $xfail_flag { + record_test XPASS $message + } else { + record_test PASS $message + } +} + +# +# Record that a test has failed +# +proc fail { message } { + global xfail_flag + + if $xfail_flag { + record_test XFAIL $message + } else { + record_test FAIL $message + } +} + +# +# Record that a test has passed unexpectedly +# +proc xpass { message } { + record_test XPASS $message +} + +# +# Record that a test has failed unexpectedly +# +proc xfail { message } { + record_test XFAIL $message +} + +# +# Set warning threshold +# +proc set_warning_threshold { threshold } { + set warning_threshold $threshold +} + +# +# Get warning threshold +# +proc get_warning_threshold { } { + return $warning_threshold +} + +# +# Prints warning messages +# These are warnings from the framework, not from the tools being tested. +# It takes a string, and an optional number and returns nothing. +# +proc warning { args } { + global warncnt + global errno + + if { [llength $args] > 1 } { + set warncnt [lindex $args 1] + } else { + incr warncnt + } + set message [lindex $args 0] + + clone_output "WARNING: $message" + set errno "WARNING: $message" + + global errorInfo + if [info exists errorInfo] { + unset errorInfo + } +} + +# +# Prints error messages +# These are errors from the framework, not from the tools being tested. +# It takes a string, and an optional number and returns nothing. +# +proc perror { args } { + global errcnt + global errno + + if { [llength $args] > 1 } { + set errcnt [lindex $args 1] + } else { + incr errcnt + } + set message [lindex $args 0] + + clone_output "ERROR: $message" + set errno "ERROR: $message" + + global errorInfo + if [info exists errorInfo] { + unset errorInfo + } +} + +# +# Prints informational messages +# +# These are messages from the framework, not from the tools being tested. +# This means that it is currently illegal to call this proc outside +# of dejagnu proper. +# +proc note { message } { + clone_output "NOTE: $message" + + # ??? It's not clear whether we should do this. Let's not, and only do + # so if we find a real need for it. + #global errorInfo + #if [info exists errorInfo] { + # unset errorInfo + #} +} + +# +# untested -- mark the test case as untested +# +proc untested { message } { + record_test UNTESTED $message +} + +# +# Mark the test case as unresolved +# +proc unresolved { message } { + record_test UNRESOLVED $message +} + +# +# Mark the test case as unsupported +# +# Usually this is used for a test that is missing OS support. +# +proc unsupported { message } { + record_test UNSUPPORTED $message +} + + +# +# Create an exp_continue proc if it doesn't exist +# +# For compatablity with old versions. +# +global argv0 +if ![info exists argv0] { + proc exp_continue { } { + continue -expect + } +} diff --git a/contrib/bluegnu2.0.3/lib/libgloss.exp b/contrib/bluegnu2.0.3/lib/libgloss.exp new file mode 100644 index 0000000..7e54e8d --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/libgloss.exp @@ -0,0 +1,225 @@ +# 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) + +# +# Find the linker script for the current target. Returns a string +# suitable to pass to $CC or $CXX to use a liblgoss based linker script, +# or NULL if there is no support. +# +proc libgloss_script { } { + global srcdir + global target_cpu + global LDFLAGS + global CFLAGS + global CXXFLAGS + global target_info + + # sanity check + if ![info exists LDFLAGS] { + set LDFLAGS "" + } + if ![info exists CFLAGS] { + set CFLAGS "" + } + + if ![info exists CXXFLAGS] { + set CXXFLAGS "" + } + + # find the linker script. first we look at the config + # data and hope to find it all ready for us to use. if + # that fails, then look in the LDFLAGS and CFLAGS variables that + # get set in the global site.exp file. + if [info exists target_info(target,name)] { + set script $target_info(target,name).ld + } else { + if [regexp -- "-T.*\.ld" ${LDFLAGS} script] { + string trimleft ${script} "-T" + } + if [regexp -- "-T.*\.ld" ${CFLAGS} script] { + string trimleft ${script} "-T" + } + if [regexp -- "-T.*\.ld" ${CXXFLAGS} script] { + string trimleft ${script} "-T" + } + } + + if ![info exists script] { + warning "Couldn't find the linker script name for target" + return "" + } + + # if we're on a remote host, we can't search for the file, so use the + # linker script in the path. + if [is3way] { + return "-T${script}" + } + + # search for the general directories + foreach i ".. ../.. ../../.. ../../../.." { + verbose "Looking for a ${srcdir}/${i}/libgloss/${target_cpu}/${script}" 2 + if [file exists ${srcdir}/$i/libgloss/${target_cpu}/${script} ] { + verbose "Found ${srcdir}/${i}/libgloss/${target_cpu}/${script}." 3 + return "-T${srcdir}/${i}/libgloss/${target_cpu}/${script}" + } + } + + # we didn't find the script, so we have to hope it's installed + return "-T${script}" +} + +# +# Find all the pieces of libgloss for testing the GNU development tools +# needed to use $CC or $CXX. It returns a string suitable to pass to +# $CC or $CXX to get a fully linked binary for the target. +# +proc libgloss_flags { } { + global target_alias + global target_cpu + global srcdir + global base_dir + + # libgloss doesn't work native + if [isnative] { + return "" + } + + # if we're on a remote host, we can't search for the file, so we can only + # use an installed compiler, so we don't add any paths here. + if [is3way] { + return "[libgloss_script]" + } + + # search for the general directories + foreach i ".. ../.. ../../.. ../../../.." { + if [file exists ${base_dir}/${i}/${target_alias}/libgloss/${target_cpu} ] { + verbose "Found ${base_dir}/${i}/${target_alias}/libgloss/${target_cpu}." 3 + return "-L${base_dir}/${i}/${target_alias}/libgloss/${target_cpu} [libgloss_script]" + } + } + + # we didn't find any support at all + return "[libgloss_script]" +} + +# +# Find the C libraries +# +proc newlib_flags { } { + global base_dir + global srcdir + global target_alias + + # if we're on a remote host, we can't search for the file, so use the + # newlib already installed. + if [is3way] { + return "" + } + + # search for the general directories + foreach i ".. ../.. ../../.. ../../../.." { + verbose "Looking for a ${base_dir}/${i}/${target_alias}/newlib/targ-include" 2 + if [file exists ${base_dir}/${i}/${target_alias}/newlib/targ-include ] { + verbose "Found ${base_dir}/${i}/${target_alias}/newlib/targ-include." 3 + set incls1 "-I${base_dir}/${i}/${target_alias}/newlib/targ-include" + } + verbose "Looking for a ${srcdir}/${i}/newlib/libc/include" 2 + if [file exists ${srcdir}/${i}/newlib/libc/include ] { + verbose "Found ${srcdir}/${i}/newlib/libc/include." 3 + set incls2 "-I${srcdir}/${i}/newlib/libc/include" + } + } + + # search for the general directories + foreach i ".. ../.. ../../.. ../../../.." { + verbose "Looking for a ${base_dir}/${i}/newlib" 2 + if [file exists ${base_dir}/${i}/newlib ] { + verbose "Found ${base_dir}/${i}/newlib." 3 + return "-B${base_dir}/${i}/newlib/ ${incls1} ${incls2}" + } + } + return "" +} + +# +# Find all the pieces of libgloss for testing the GNU development tools +# needed to use $LD. This gets fun cause we have to guess the name of the +# BSP for this target. If returns a string suitable to pass to LD to get +# a fully linked binary for the target. It also sets two global variables, +# CRT0 is the path to the startup file, and +# BSP is the path to the support library. +# +proc libgloss_ld {} { +#proc gloss_ld {} { + global target_cpu + global srcdir + global base_dir + global CRT0 + global BSP + + # libgloss doesn't work native + if [isnative] { + return "" + } + +# set ldflags "" + # search for the general directories + foreach i ".. ../.. ../../.. ../../../.." { + if ![info exists gloss_srcdir] { + if [file exists ${srcdir}/$i/libgloss/${target_cpu} ] { + verbose "Found ${srcdir}/$i/libgloss/${target_cpu}." 3 + set gloss_srcdir "$i/libgloss/${target_cpu}" + } + } + if ![info exists gloss_objdir] { + if [file exists ${base_dir}/$i/libgloss/${target_cpu} ] { + verbose "Found ${base_dir}/$i/libgloss/${target_cpu}." 3 + set gloss_objdir "$i/libgloss/${target_cpu}" + append ldflags " -L${gloss_objdir} " + } + } + } + + # find the crt0 + if [file exists ${gloss_objdir}/crt0.o] { + verbose "Found ${base_dir}/$i/libgloss/${target_cpu}." 3 + set CRT0 "$i/libgloss/${target_cpu}" + append ldflags " ${gloss_objdir}/crt0.o " + } else { + perror "No crt0.o built for this target" + } + + # find the BSP (currently an object, it may become an archive soon) + foreach i "[list_targets]" { + if [info exists target_info($i,name}] { + if [file exists ${gloss_objdir}/${target_info}($i,name).o ] { + set BSP "${target_info}($i,name).o" + append ldflags " -lc -l ${target_info}($i,name).o -lc " + } + } + } + if [expr ![info exists gloss_srcdir] || ![info exists gloss_srcdir]] { + warning "No libgloss support in build tree" + return "" + } else { + return "${ldflags}" + } +} diff --git a/contrib/bluegnu2.0.3/lib/nonexpect.itcl b/contrib/bluegnu2.0.3/lib/nonexpect.itcl new file mode 100644 index 0000000..230f411 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/nonexpect.itcl @@ -0,0 +1,74 @@ +# +# The following procedures are creted to replace the +# procedures defined in expect incase expect is not used as the +# test framework +# + +proc send_user args { + set newline 1 + set logfile 0 + set i 0 + if { [string index [lindex $args 0] 0] == "-" } { + for { set i 0 } { $i < [llength $args] } { incr i } { + if { [lindex $args $i] == "--" } { + incr i + break + } elseif { [lindex $args $i] == "-n" } { + set newline 0 + } elseif { [lindex $args $i] == "-log" } { + set logfile 1 + } elseif { [string index [lindex $args $i] 0] == "-" } { + ::BlueGnu::clone_output "ERROR: verbose:\ + illegal argument: [lindex $args $i]" + return + } else { + break + } + } + if { [llength $args] == $i } { + ::BlueGnu::clone_output "ERROR: send_user: nothing to print" + return + } + } + puts -nonewline [lindex $args $i] +} + +proc send_error msg { + puts -nonewline stderr $msg +} + +proc send_log msg { + global log_file + + if {[info exists log_file]} { + puts -nonewline $log_file $msg + } else { + send_user "####### No log file has been defined\n" + puts -nonewline stderr $msg + } +} + +proc log_file {args} { + global log_file + if {[info exists log_file]} { + catch {close $log_file} + unset log_file + } + set eAppend w + foreach arg $args { + switch -- $arg { + -a { + set eAppend a + } + default { + set log_file $arg + } + } + } + if {[info exist log_file]} { + set log_file [open $log_file $eAppend] + } else { + set log_file stderr + } +} + diff --git a/contrib/bluegnu2.0.3/lib/remote.exp b/contrib/bluegnu2.0.3/lib/remote.exp new file mode 100644 index 0000000..1b80617 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/remote.exp @@ -0,0 +1,896 @@ +# 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 +} diff --git a/contrib/bluegnu2.0.3/lib/serverUtils.itcl b/contrib/bluegnu2.0.3/lib/serverUtils.itcl new file mode 100644 index 0000000..7e7c8bb --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/serverUtils.itcl @@ -0,0 +1,51 @@ +# +# +# + +proc EvalServer {port {interp {}} {openCmd EvalOpenProc}} { + puts "in EvalServer" + socket -server [list EvalAccept $interp $openCmd] $port +} + +proc EvalAccept {interp openCmd newsock addr port} { + global eval + + puts "in EvalAccept" + set eval(cmdbuf,$newsock) {} + puts "[fconfigure $newsock]" + fconfigure $newsock -buffering line + fileevent $newsock readable [list EvalRead $newsock $interp] + puts "in EvalAccept: got fileevent" + if [catch { + interp eval $interp $openCmd $newsock $addr $port + }] { + close $newsock + } +} + +proc EvalOpenProc {sock addr port} { + puts "in EvalOpenProc" + # dummy +} + +proc EvalRead {sock interp} { + global eval errorInfo errorCode + + puts "in EvalRead" + if [eof $sock] { + close $sock + } else { + gets $sock line + append eval(cmdbuf,$sock) "$line\n" + if {[string length $eval(cmdbuf,$sock)] && \ + [info complete $eval(cmdbuf,$sock)]} { + puts ">$eval(cmdbuf,$sock)<" + } + set reply "Done\n" + puts $sock 1 + puts -nonewline $sock $reply + flush $sock + set eval(cmdbuf,$sock) {} + } +} + 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" +} diff --git a/contrib/bluegnu2.0.3/lib/tclIndex b/contrib/bluegnu2.0.3/lib/tclIndex new file mode 100644 index 0000000..7b09971 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/tclIndex @@ -0,0 +1,21 @@ +# Tcl autoload index file: each line identifies a Tcl + +doCmd testSessionFramework.itcl + +send_user nonexpect.itcl +send_error nonexpect.itcl +send_log nonexpect.itcl +log_file nonexpect.itcl + +::BlueGnu::Application testSessionApplication.itcl +::BlueGnu::Environment testSessionClasses.itcl +::BlueGnu::Target testSessionClasses.itcl +::BlueGnu::Test testSessionClasses.itcl +::BlueGnu::Queue testSessionClasses.itcl +::BlueGnu::Error testSessionClasses.itcl + +Default Default_target.itcl +BlueGnu BlueGnu_target.itcl + +# Types +Type Types.itcl diff --git a/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl b/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl new file mode 100644 index 0000000..3d57722 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/testSessionApplication.itcl @@ -0,0 +1,314 @@ +# +# This file defines the Application Class +# + +source $env(BLUEGNULIB)/testSessionFramework.itcl +source $env(BLUEGNULIB)/testSessionClasses.itcl + +namespace eval ::BlueGnu { + class Application { + protected variable szName "Default" + protected variable lTargets {} + protected variable lTests + protected variable szCurrentTarget + protected variable objCurrentTarget + protected variable objEnvironment + protected variable szOutDir + + constructor {args} { + debug {======= Doing Application construction} 3 + set szOutDir "..." + foreach varval $args { + set varval [split $varval "="] + if {[llength $varval] != 2} { + error "Missing <variable>=<value> pair" + } + set var [lindex $varval 0] + set val [lindex $varval 1] + set variables {} + foreach v [lsort [info variable]] { + regexp {[^:]+$} $v v + lappend variables $v + } + if {[lsearch -exact $variables $var] >= 0} { + set $var $val + } else { + error "$var does not exists in Class [info class]" + } + } + } + + destructor { + } + + public method execute {} { + debug {======= Starting with Execution of the Application} 3 + debug { list of indexes for lTests is [array names lTests]} 4 + set iTarget 0 + set objEnvironment [uplevel #0 \ + "::BlueGnu::Environment #auto \ + szName=$szName"] + debug { objEnvironment = >$objEnvironment<} 3 + debug { +++ [infoWhich $objEnvironment] +++} 4 + debug { === [::itcl::find objects] ===} 4 + uplevel #0 set objCurrentEnvironment $objEnvironment + foreach target $lTargets { + set szTargetName [lindex [split $target "="] 0] + open_logs $szTargetName + incr iTarget + # set current Test Suite Namespace + uplevel #0 set nspTestSuite "::TestSuite[format %.5d $iTarget]" + debug { Processing target: >$target< in Test Suite\ + [uplevel set nspTestSuite]} 3 + namespace eval [uplevel set nspTestSuite] { + debug { Context is >[namespace current]<} 3 + variable iTestNr 0 + proc autoTest {} { + variable iTestNr + + incr iTestNr + debug {iTestNr = $iTestNr} 5 + debug {namespace current = >[namespace current]<} 5 + debug {format = >T[format %.5d $iTestNr]<} 5 + return [namespace current]::T[format %.5d $iTestNr] + } + + set target [uplevel set target] + debug { In namespace eval [namespace current]\ + for target: >$target<} 3 + if {! [catch { + if {[string length $target] == 0} { + # Create a default Target Object + # + debug { Create a default Target Object} 3 + uplevel #0 set objCurrentTarget \ + [infoWhich \ + [::BlueGnu::Target #auto \ + szID=default \ + szName=default \ + objQueue=[infoWhich [::BlueGnu::Queue #auto]] \ + objEnvironment=[uplevel set objEnvironment]]] + } else { + # Call the Target Procedure + # This procedure should return a Target Object. + # Arguments are passed to this procedure. + debug { Create target: >$target<} 3 + set list [split $target "="] + uplevel #0 set objCurrentTarget \ + [infoWhich \ + [eval [lindex $list 0] \ + [join [lrange $list 1 end] "="] \ + objEnvironment=[uplevel set objEnvironment]]] + } + } szErrMsg]} { + debug { Current Target is\ + >[set target \ + [uplevel #0 set objCurrentTarget]]<} 3 + + debug { Working with target index\ + [uplevel set iTarget]} 4 + if {[uplevel {info exists lTests($iTarget)}]} { + foreach test [uplevel {set lTests($iTarget)}] { + debug { test: $test} 3 + $target queue append $test + } + } + $target start + $target runTests + $target exit + + # report results of the testing + # + debug { #### All Objects: [::itcl::find objects]} 3 + foreach T [lsort [::itcl::find objects T*]] { + debug { #### Deleting Object $T\ + ([$T info class])} 0 + delete object $T + } + # remove constructed objects + # + debug { Removing Target Class Object $target} 3 + delete object $target + } else { + global errorCode errorInfo + perror "Couldn't create target >$target<!\ + \n May be no procedure with name\ + >$target< defined!\ + \n errorMsg : >$szErrMsg<\ + \n errorInfo: >$errorInfo<\ + \n errorCode: >$errorCode<" + debug { error info:\n$errorInfo} 3 + } + } + namespace delete [uplevel set nspTestSuite] + close_logs + } + debug { objects: >[::itcl::find objects]<} 4 + debug {####### deleting Object Environment >$objEnvironment<} 4 + delete object $objEnvironment + } + + public method processArguments {arguments} { + upvar $arguments argv + global szCurrentTestDirectory + + set state NORMAL + set iTarget 0 + foreach arg $argv { + switch -regexp -- $arg { + {^-a(l(l)?)?$} { + debug { all_flag set to TRUE} 4 + set ::BlueGnu::all_flag 1 + } + {^-o(u(t(d(i(r)?)?)?)?)?$} { + debug { Output Directory is next argument} 4 + set state OUTDIR + } + {^--o(u(t(d(i(r)?)?)?)?)?=.*} { + set components [split $arg "="] + debug { Processing Output Directory >$arg<} 4 + set szOutDir [lindex $components 1] + set state NORMAL + } + {^-[-]?t(a(r(g(e(t)?)?)?)?)?([=].*|$)} { + set components [split $arg "="] + if {[llength $components] == 1} { + debug { Target is next argument} 4 + set state TARGET + } else { + debug { Processing Target >$arg<} 4 + setTarget iTarget \ + [join [lrange $components 1 end] "="] + set state NORMAL + } + } + default { + debug { Processing argument: >$arg<} 3 + switch $state { + OUTDIR { + set szOutDir $arg + set state NORMAL + } + TARGET { + setTarget iTarget $arg + set state NORMAL + } + NORMAL { + set components [split $arg "="] + regexp {([^[]*)(.*)} [lindex $components 0] \ + dummy szFileName szCaseArgs + append szCaseArgs "=[join \ + [lrange $components 1 end] "="]" + debug { arg: >$arg<} 3 + debug { components: >$components<} 3 + debug { case+args: >$szCaseArgs<} 3 + debug { Test Script: >$szFileName<} 3 + debug { : >$szCurrentTestDirectory<} 3 + set szDname [file dirname $szFileName] + set szFname [file tail $szFileName] + + if {[file exist [set test [file join \ + $szCurrentTestDirectory \ + $szFileName]]]} { + # file should be a test + debug { is a test: >$test<!} 3 + if {! [info exists szCurrentTarget]} { + setTarget iTarget {} + } + lappend lTests($iTarget) \ + [file join \ + $szCurrentTestDirectory \ + $arg] + debug { Appended test:\ + >[file join \ + $szCurrentTestDirectory \ + $arg]<!} 3 + } elseif {[llength [set tests \ + [locateFile $szFname $szDname]]] > 0} { + foreach test $tests { + if {[file exists $test]} { + # file should be a test + debug { is a test:\ + >$test<!!} 3 + if {! [info exists\ + szCurrentTarget]} { + setTarget iTarget {} + } + lappend lTests($iTarget) \ + $test$szCaseArgs + debug { Appended test:\ + >$test$szCaseArgs<!!} 2 + } else { + warning "Test >$test< can't\ + be found" + } + } + } else { + perror "$szFileName is not a test!\ + Does not exists!" + } + } + } + } + } + } + debug { ==== Found tests:} 3 + foreach index [lsort [array names lTests]] { + debug { lTests($index) = $lTests($index)} 4 + } + debug { Targets are: $lTargets} 4 + } + private method setTarget {index target} { + upvar $index iTarget + + incr iTarget + if {[string length $target] == 0} { + set szCurrentTarget "Default" + lappend lTargets $szCurrentTarget + debug { Default Current Target} 3 + } else { + set szCurrentTarget $target + lappend lTargets $szCurrentTarget + debug { Current target: >$szCurrentTarget<} 3 + } + debug { Found target >$szCurrentTarget<} 3 + } + + private method open_logs {target} { + global env + + set target [string trim $target] + if {[string compare $szOutDir "..."] == 0} { + debug { No Output directory defined, creating one} 3 + set szOutDir \ + "logs/$env(USER)_${target}_[exec date +%Y%m%d]_" + set szI [format "%.4d" [set i 0]] + while {[file isdirectory $szOutDir$szI]} { + set szI [format "%.4d" [incr i]] + } + set szOutDir $szOutDir$szI + } + if {! [file isdirectory $szOutDir]} { + exec mkdir -p $szOutDir + } + if {[string length $target] == 0} { + set szTool testrun + } else { + set szTool $target + } + catch "exec rm -f $szOutDir/$szTool.sum" + namespace eval ::BlueGnu \ + "set ::BlueGnu::sum_file [open "$szOutDir/$szTool.sum" w]" + puts $::BlueGnu::sum_file "# $szOutDir/$szTool.sum" + catch "exec rm -f $szOutDir/$szTool.log" + log_file -a "$szOutDir/$szTool.log" + send_log "# $szOutDir/$szTool.log\n" + debug { Opening log and summary files in $szOutDir} 3 + } + private method close_logs {} { + } + public method outDir {} { + return $szOutDir + } + } +} diff --git a/contrib/bluegnu2.0.3/lib/testSessionClasses.itcl b/contrib/bluegnu2.0.3/lib/testSessionClasses.itcl new file mode 100644 index 0000000..a9428af --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/testSessionClasses.itcl @@ -0,0 +1,1341 @@ +# +# This [incr Tcl] source file contains the class specifications +# for the testSession of BlueGnu +# +namespace eval ::BlueGnu { + variable lArgs {} + + variable errcnt 0 + variable errno "NONE" + variable warncnt 0 + variable xfail_flag 0 + + class Common { + # arguments passed to the constructor are always in the form: + # <variable>=<value> + # + constructor {args} { + debug {Constructor for >$this< [info level] [info class]} 9 + foreach varval $args { + set varval [split $varval "="] + if {[llength $varval] != 2} { + error "Missing <variable>=<value> pair" + } + set var [lindex $varval 0] + set val [lindex $varval 1] + set variables {} + foreach v [lsort [info variable]] { + regexp {[^:]+$} $v v + lappend variables $v + } + if {[lsearch -exact $variables $var] >= 0} { + set $var $val + } else { + perror "variable >$var< does not exists in Class\ + [info class]\n \ + (was passed as argument and is ignored!)" + } + } + } + + public method << {} { + set lResult {} + foreach var [lsort [info variable]] { + regexp {[^:]+$} $var v + debug {Found variable: >$v<} 9 + if [array exists $v] { + debug { is an array} 9 + foreach index [lsort [array names $v]] { + lappend lResult "${v}($index)=[set ${v}($index)]" + } + } else { + debug { is simple variable} 9 + if {[string compare [set value [info variable $var -value]] \ + "<undefined>"] != 0} { + switch $v { + this - + text {} + default { + lappend lResult [list $v $value] + } + } + } + } + } + set lResult + } + } + + class Test { + inherit Common + + protected variable szID + protected variable bTestCase + protected variable szTestCase + protected variable szTestCaseID + protected variable szTestCaseArgs + protected variable szName + protected variable szTool + protected variable eType + protected variable eResult + protected variable szScriptName + protected variable lArguments + protected variable szHostName + protected variable iPassed + protected variable iFailed + protected variable iXPassed + protected variable iXFailed + protected variable iCrashed + protected variable iError + protected variable iWarning + protected variable iUnresolved + protected variable iUntested + protected variable iUnsupported + protected variable i + protected variable benchmarkObject + protected variable benchmarkClassName + + constructor testScript { + set szTool [uplevel #0 set szCurrentTestDirectory] + debug {======= Global Default Test Directory is\ + >$szTool<} 5 + + set lArguments {} + # remove all multiple spaces/tabs into one space + # and parse the argument list + # <testScript> ::= <szScriptName>?[test case ID]?=<argument list> + # <argument list> ::= <argument> <argument list> + # <argument> ::= <variable name> | <variable name>=<value> + debug { testScript(1) is >$testScript<} 5 + regsub -all "(\[ \t\]+)" [string trim $testScript] " " testScript + debug { testScript(2) is >$testScript<} 5 + # + # Split testScript into script, test case ID, and arguments + regexp {^([^[=]+)([[]([^]]+)[]])?(=(.*))?$} $testScript dummy \ + script tc tcID argT argL + debug { script: >$script<} 5 + debug { tc: >$tc<} 5 + debug { tcID: >$tcID<} 5 + debug { argT: >$argT<} 5 + debug { argL: >$argL<} 5 + if {[set i [string first {=} $testScript]] >= 0} { + set testScriptArgs [string range $testScript \ + [expr $i + 1] end] + set testScript [string range $testScript 0 [expr $i - 1]] + } else { + set testScriptArgs {} + } + set testScript $script + set szTestCase $tcID + if {[string length $szTestCase] > 0} { + set bTestCase 1 + } else { + set bTestCase 0 + } + set szTestCaseID [lindex [split $szTestCase "="] 0] + set szTestCaseArgs [join [lrange [split $szTestCase "="] 1 end] \ + "="] + debug {szTestCase == >$szTestCase<} 5 + debug {szTestCaseID == >$szTestCaseID<} 5 + debug {szTestCaseArgs == >$szTestCaseArgs<} 5 + set testScriptArgs $argL + debug {testScript(3) is >$testScript<} 5 + debug {testScriptArgs(1) is >$testScriptArgs<} 5 + set lArguments [eval list $testScriptArgs] + set i 0 + foreach arg $lArguments { + debug {arg($i) is >$arg<} 5 + set lArguments [lreplace $lArguments $i $i [split $arg "="]] + incr i + } + debug {Test script >$testScript<, test case >$szTestCase<} 3 + debug { pathtype is [file pathtype $testScript]} 3 + switch [file pathtype $testScript] { + relative { + error "Test Script name >$testScript<\ + should not be relative" + } + absolute { + debug {Absolute reference in $this to Test Script\ + >$testScript<} 3 + set szScriptName $testScript + } + } + debug {Default Test Directory is >$szTool<} + if {[file exists $testScript]} { + debug {Test script >$testScript< exists!} + set szName [file tail $testScript] + set szID [file rootname $szName] + set szPWD [pwd] + set szTool [file dirname $testScript] + cd $szTool + set szTool [pwd] + cd $szPWD + set szScriptName [file join $szTool [file tail $testScript]] + regsub {.} [string toupper [file extension $szName]] {} eType + set eResult INITIALIZED + } else { + debug {Test script >$testScript< does NOT exists!} + set szRoot "" + set szID "" + set szName "" + set szTool "" + uplevel #0 set szCurrentTestDirectory "\"$szTool\"" + set eType "NONE" + set szScriptName "$testScript" + set lArguments {} + set eResult EMPTY + } + set szHostName [info host] + set iPassed 0 + set iFailed 0 + set iXPassed 0 + set iXFailed 0 + set iCrashed 0 + set iError 0 + set iWarning 0 + set iUnresolved 0 + set iUntested 0 + set iUnsupported 0 + debug {Default Test Directory is >$szTool<} + debug {Global Default Test Directory is\ + >[uplevel #0 set szCurrentTestDirectory]<} + + debug {Target: >[[uplevel #0 set objCurrentTarget] <<]<} + + while {1} { + # Create Benchmark Class Object + # + # First initialize + # + set szTargetID [[uplevel #0 set objCurrentTarget] ID] + regsub -all {[^a-zA-Z0-9_]} $szTargetID "_" szTargetID + regsub -all {[^a-zA-Z0-9_]} $szID "_" szTmpID + regsub -all {[^a-zA-Z0-9_]} $szTestCaseID "_" szTmpTestCaseID + # + # First try Benchmark Class in namespace for Target + # and test case ID if exists otherwise test script ID + # + set benchmarkClassName ::$szTargetID + if {$bTestCase} { + append benchmarkClassName ::$szTmpTestCaseID + } else { + append benchmarkClassName ::$szTmpID + } + debug {=== Trying benchmark: $benchmarkClassName} 3 + if [catch { + set benchmarkObject \ + [eval $benchmarkClassName #auto $szTestCaseArgs] + if {! [string match ::* $benchmarkObject]} { + set benchmarkObject \ + [namespace current]::$benchmarkObject + } + debug {benchmarkObject: >$benchmarkObject<} 3 + } errMsg] { + debug {Error Msg: >>>$errMsg<<<} 3 + debug { info: >>>[uplevel #0 set errorInfo]<<<} 4 + } else { + break + } + # + # Now try Benchmark class for test script name + # with test case ID or Benchmark + # + set benchmarkClassName ::$szTmpID + if {$bTestCase} { + append benchmarkClassName ::$szTmpTestCaseID + } else { + append benchmarkClassName ::Benchmark + } + debug {=== Trying benchmark: $benchmarkClassName} 3 + if [catch { + set benchmarkObject [infoWhich \ + [eval $benchmarkClassName #auto $szTestCaseArgs]] + } errMsg] { + debug {Error Msg: >>>$errMsg<<<} 3 + debug { info: >>>[uplevel #0 set errorInfo]<<<} 4 + } else { + break + } + # + # Now try target ID and benchmark + # + set benchmarkClassName ::${szTargetID}::Benchmark + debug {=== Trying benchmark: $benchmarkClassName} 3 + debug { namespace: >[namespace current]<} 3 + if [catch { + set benchmarkObject [infoWhich \ + [eval $benchmarkClassName #auto $szTestCaseArgs] \ + [namespace current]] + } errMsg] { + debug {Error Msg: >>>$errMsg<<<} 3 + debug { info: >>>[uplevel #0 set errorInfo]<<<} 4 + } else { + break + } + # + # Now try the generic BlueGnu benchmark function + # + set benchmarkClassName ::BlueGnu::Benchmark + debug {=== Trying benchmark: $benchmarkClassName} 3 + if [catch { + set benchmarkObject [infoWhich \ + [eval $benchmarkClassName #auto $szTestCaseArgs]] + debug {[warning "Default Benchmark Class\ + is being used!"]} + } errMsg] { + warning "NO Benchmark Class >$benchmarkClassName<\ + defined" + debug {[warning "Class: >$benchmarkClassName<\ + has not been defined.\n ### Error Msg:\ + $errMsg"]} + set benchmarkObject "" + break + } + debug { benchmark: $benchmarkClassName\ + ($benchmarkObject)} 3 + uplevel #0 { + set errorInfo NONE + } + break + } + } + + destructor { + setResult + switch $eResult { + PASSED { + printResult + if {! $bTestCase} { + ::BlueGnu::clone_output " Statistics :\ + $iPassed (PASS),\ + $iXFailed (XFAIL)" + } + } + FAILED { + printResult + if {! $bTestCase} { + ::BlueGnu::clone_output " Statistics :\ + $iPassed (PASS),\ + $iXFailed (XFAIL)" + ::BlueGnu::clone_output " :\ + $iFailed (FAIL),\ + $iXPassed (XPASS)" + } + } + UNKNOWN { + } + default { + printResult + if {! $bTestCase} { + ::BlueGnu::clone_output " Statistics :\ + $iPassed (PASS),\ + $iXFailed (XFAIL)" + ::BlueGnu::clone_output " :\ + $iFailed (FAIL),\ + $iXPassed (XPASS)" + if {$iUntested} { + ::BlueGnu::clone_output " :\ + $iUntested (UNTESTED)" + } + if {$iUnresolved} { + ::BlueGnu::clone_output " :\ + $iUnresolved (UNRESOLVED)" + } + if {$iUnsupported} { + ::BlueGnu::clone_output " :\ + $iUnsupported (UNSUPPORTED)" + } + if {$iCrashed} { + ::BlueGnu::clone_output " :\ + $iCrashed (CRASHED)" + } + if {$iError} { + ::BlueGnu::clone_output " :\ + $iError (ERROR)" + } + if {$iWarning} { + ::BlueGnu::clone_output " :\ + $iWarning (WARNING)" + } + } + } + } + # remove benchmark Class Object + # + if {$benchmarkObject != ""} { + debug {#### Benchmark Object: >$benchmarkObject<\ + ([catch {$benchmarkObject info class}])} 3 + debug {#### Benchmark Class : >$benchmarkClassName<} 3 + catch {delete object $benchmarkObject} + if {$benchmarkClassName != "::BlueGnu::Benchmark"} { + catch {delete class $benchmarkClassName} + } + } + ::BlueGnu::clone_output "" + } + + private method printResult {} { + if {$bTestCase} { + ::BlueGnu::clone_output "******* Result :\ + [format "%-12s" $eResult] for test case :\ + >$szTestCase<" + } else { + ::BlueGnu::clone_output "******* Result :\ + [format "%-12s" $eResult] for test script :\ + >$szID<" + } + } + + public method ID {} { + return $szID + } + + public method testCase {} { + return $szTestCase + } + + public method testCaseID {} { + return $szTestCaseID + } + + public method testCaseArgs {} { + return $szTestCaseArgs + } + + public method benchmarkObject {} { + return $benchmarkObject + } + + public method benchmarkClassName {} { + return $benchmarkClassName + } + + public method name {args} { + if {[llength $args] == 1} { + set szName [lindex $args 0] + } + return $szName + } + + public method result {} { + return $eResult + } + + public method arguments {} { + return $lArguments + } + + public method pass {szMsg} { + global objCurrentEnvironment + if {[namespace eval ::BlueGnu {set xfail_flag}]} { + incr iXPassed + $objCurrentEnvironment record_test XPASS $szMsg + } else { + incr iPassed + $objCurrentEnvironment record_test PASS $szMsg + } + setResult + } + public method fail {szMsg} { + global objCurrentEnvironment + if {[namespace eval ::BlueGnu {set xfail_flag}]} { + incr iXFailed + $objCurrentEnvironment record_test XFAIL $szMsg + } else { + incr iFailed + $objCurrentEnvironment record_test FAIL $szMsg + } + setResult + } + + public method perror {szMsg} { + global objCurrentEnvironment + incr iError + $objCurrentEnvironment record_test ERROR $szMsg + setResult + } + + public method crashed {szMsg} { + global objCurrentEnvironment + incr iCrashed + $objCurrentEnvironment record_test CRASHED $szMsg + setResult + } + + public method warning {szMsg} { + global objCurrentEnvironment + incr iWarning + $objCurrentEnvironment record_test WARNING $szMsg + setResult + } + + public method note {szMsg} { + global objCurrentEnvironment + $objCurrentEnvironment record_test NOTE $szMsg + } + + public method unresolved {szMsg} { + global objCurrentEnvironment + incr iUnresolved + $objCurrentEnvironment record_test UNRESOLVED $szMsg + } + public method untested {szMsg} { + global objCurrentEnvironment + incr iUntested + $objCurrentEnvironment record_test UNTESTED $szMsg + } + public method unsupported {szMsg} { + global objCurrentEnvironment + incr iUnsupported + $objCurrentEnvironment record_test UNSUPPORTED $szMsg + } + + private method setResult {} { + if {$iUnresolved || \ + $iError || $iCrashed || \ + ($iWarning > [namespace eval ::BlueGnu { \ + set warning_threshold}] && \ + 0 < [namespace eval ::BlueGnu { \ + set warning_threshold}])} { + set eResult UNRESOLVED + } elseif {$iUntested} { + set eResult UNTESTED + } elseif {$iUnsupported} { + set eResult UNSUPPORTED + } elseif {($iPassed > 0 || $iXFailed > 0) && \ + $iFailed == 0 && $iXPassed == 0} { + set eResult "PASSED" + } elseif {$iFailed || $iXPassed} { + set eResult "FAILED" + } elseif {$iPassed == 0 && $iXPassed && \ + $iFailed == 0 && $iXFailed && $iCrashed == 0 && \ + $iError == 0 && $iWarning == 0} { + set eResult ACTIVATED + } else { + set eResult UNKNOWN + } + } + + public method getResult {} { + setResult + return $eResult + } + + public method tool {} { + return $szTool + } + + public method scriptName {} { + return $szScriptName + } + + public method << {} { + if 0 { + lappend lResult [list ID $szID] + lappend lResult [list name $szName] + lappend lResult [list tool $szTool] + lappend lResult [list type $eType] + lappend lResult [list result $eResult] + lappend lResult [list root $szRoot] + lappend lResult [list script $szScriptName] + lappend lResult [list arguments $lArguments] + lappend lResult [list host $szHostName] + + return $lResult + } else { + eval [info function Common::<< -body] + } + } + + public method runtest {} { + global objCurrentEnvironment + setResult + + if {$bTestCase} { + ::BlueGnu::clone_output "####### Begin test case :\ + >$szTestCase<" + debug { [scriptName]\n \ + [name]=[arguments]} + } else { + ::BlueGnu::clone_output "####### Begin test script :\ + >$szID<" + debug { [scriptName]\n \ + [name]=[arguments]} + } + verbose { Full Pathname : $szScriptName} 1 + debug {=== Running test in $this: $szScriptName} 3 + debug {[join [<<] "\n"]} 9 + catch {debug {Global Default Test Directory is\ + >[uplevel #0 set szCurrentTestDirectory]<}} + catch {debug {Default Test Directory is >$szTool<}} + + if [catch { + uplevel #0 set szCurrentTestDirectory "$szTool" + uplevel #0 lappend lTool {$szCurrentTestDirectory} + uplevel #0 set objCurrentTest $this + uplevel #0 lappend lTestName {$objCurrentTest} + uplevel 1 variable bTestCase $bTestCase + uplevel 1 variable szTestCase \"$szTestCase\" + uplevel 1 variable szTestCaseID \"$szTestCaseID\" + uplevel 1 variable szTestCaseArgs \"$szTestCaseArgs\" + uplevel 1 variable iArgs [llength $lArguments] + uplevel 1 variable lArgs [concat {[list} $lArguments {]}] + uplevel 1 variable szID $szID + uplevel 1 variable szScriptName $szScriptName + uplevel 1 variable szName $szName + uplevel 1 variable szTool $szTool + } szErrMsg] { + debug {Error Msg:>>>$szErrmsg<<<} 0 + } + if {[catch {uplevel 1 source $szScriptName} szErrMsg]} { + global errorInfo errorCode + crashed ">$szErrMsg<\ + \n in script: >$szScriptName<\ + \n errorInfo: >$errorInfo<\ + \n errorCode: >$errorCode<" + } + setResult + $objCurrentEnvironment reportTestResult $eResult + + uplevel #0 {set lTestName [lreplace $lTestName end end]} + uplevel #0 {set objCurrentTest [lrange $lTestName end end]} + uplevel #0 {set lTool [lreplace $lTool end end]} + uplevel #0 {set szCurrentTestDirectory [lrange $lTool end end]} + + catch {debug {Default Test Directory is >$szTool<} 3} + catch {debug {Global Default Test Directory is\ + >[uplevel #0 set szCurrentTestDirectory]<} 3} + debug {=== Done with test in $this: $szScriptName ($bTestCase)} 3 + if {$bTestCase} { + ::BlueGnu::clone_output "####### End test case :\ + >$szTestCase<" + } else { + ::BlueGnu::clone_output "####### End test script :\ + >$szID<" + } + return $this + } + } + + class Queue { + inherit Common + + protected variable lTestNames + + constructor {} { + set lTestNames {} + } + + public method append args { + set testName [join $args] + debug { queue appending >$testName<} 3 + lappend lTestNames $testName + debug { DONE} 3 + } + + public method prepend args { + #set testName [join $args] + debug {Queue::prepend $args} 3 + foreach arg $args { + debug { append >$arg< to comList} 3 + lappend comList $arg + } + debug { queue prepending comList: >$comList<} 3 + debug { [llength $comList] elements in comList} 3 + #set lTestNames [linsert $lTestNames 0 "$testName"] + debug { [llength $lTestNames] elements in lTestNames} 3 + set lTestNames [concat $comList $lTestNames] + debug { [llength $lTestNames] elements in lTestNames} 3 + debug { DONE} 3 + } + + public method pop {} { + if {[llength $lTestNames] == 0} { + return -code error -errorinfo "Empty Queue" {} + } + if {[llength $lTestNames] == 1} { + set testName [lindex $lTestNames 0] + set lTestNames {} + return $testName + #return -code error $testName + } + set testName [lindex $lTestNames 0] + set lTestNames [lrange $lTestNames 1 end] + return $testName + } + + public method << {} { + #lappend lResult [list tests $lTestNames] + + #return $lResult + eval [info function Common::<< -body] + } + } + + class Environment { + inherit Common + + protected variable szName "Default" + + protected variable iPassCnt 0 + protected variable iFailCnt 0 + protected variable iXPassCnt 0 + protected variable iXFailCnt 0 + protected variable iUntestedCnt 0 + protected variable iUnresolvedCnt 0 + protected variable iUnsupportedCnt 0 + protected variable iCrashedCnt 0 + protected variable iErrorCnt 0 + protected variable iWarningCnt 0 + protected variable iCnt 0 + + protected variable iWarningThreshold 0 + protected variable iErrorThreshold 0 + + protected variable bXFailFlag 0 + protected variable bExitStatus 0 + + protected variable eResult UNKNOWN + protected variable iUntested 0 + protected variable iUnsupported 0 + protected variable iUnresolved 0 + protected variable iPassed 0 + protected variable iFailed 0 + + + protected variable ENV + protected variable bSaved 0 + common defaultEnvironment [list PATH FPATH \ + BLUEGNULIB TESTSUITEROOT TESTSETS TMPDIR \ + DISPLAY EDITOR EMACSFONT HOME LANG LOGIN LOGNAME SHELL \ + TERM USER WINDOWID DEBUG LPDEST \ + ORGANIZATION OSTYPE PAGER \ + PARM_SEARCH_PATH \ + ] + + constructor {args} { + debug {Level in Constructor: [info level]} 9 + eval [info function Common::constructor -body] + setResult + } + + destructor { + global objCurrentTarget + debug {******* [info class]::destructor} 3 + + ::BlueGnu::clone_output "******* Result :\ + [format "%-12s" $eResult]\ + for test session : >$szName<" + switch $eResult { + PASSED { + ::BlueGnu::clone_output " Statistics :\ + $iPassed (PASS)" + ::BlueGnu::clone_output "******* Cumulative statistics\ + for all test script!" + ::BlueGnu::clone_output " Statistics Totals :\ + $iPassCnt (PASS),\ + $iXFailCnt (XFAIL)" + if {$iUntested} { + ::BlueGnu::clone_output " :\ + $iUntested (UNTESTED)" + } + if {$iWarningCnt} { + ::BlueGnu::clone_output " :\ + $iWarningCnt (WARNING)" + } + } + UNKNOWN - + default { + ::BlueGnu::clone_output " Statistics :\ + $iPassed (PASS)" + ::BlueGnu::clone_output " :\ + $iFailed (FAIL)" + if {$iUntested} { + ::BlueGnu::clone_output " :\ + $iUntested (UNTESTED)" + } + if {$iUnresolved} { + ::BlueGnu::clone_output " :\ + $iUnresolved (UNRESOLVED)" + } + if {$iUnsupported} { + ::BlueGnu::clone_output " :\ + $iUnsupported (UNSUPPORTED)" + } + ::BlueGnu::clone_output "******* Cumulative statistics\ + for all test script!" + ::BlueGnu::clone_output " Statistics Totals :\ + $iPassCnt (PASS),\ + $iXFailCnt (XFAIL)" + ::BlueGnu::clone_output " :\ + $iFailCnt (FAIL),\ + $iXPassCnt (XPASS)" + if {$iUntestedCnt} { + ::BlueGnu::clone_output " :\ + $iUntestedCnt (UNTESTED)" + } + if {$iUnresolvedCnt} { + ::BlueGnu::clone_output " :\ + $iUnresolvedCnt (UNRESOLVED)" + } + if {$iUnsupportedCnt} { + ::BlueGnu::clone_output " :\ + $iUnsupportedCnt (UNSUPPORTED)" + } + if {$iCrashedCnt} { + ::BlueGnu::clone_output " :\ + $iCrashedCnt (CRASHED)" + } + if {$iErrorCnt} { + ::BlueGnu::clone_output " :\ + $iErrorCnt (ERROR)" + } + if {$iWarningCnt} { + ::BlueGnu::clone_output " :\ + $iWarningCnt (WARNING)" + } + } + } + if {$::BlueGnu::errcnt} { + ::BlueGnu::clone_output "####### Encountered\ + $::BlueGnu::errcnt System Errors!" + } + ::BlueGnu::clone_output "###########################\n" + } + + public method name {} { + return $szName + } + + public method record_test {type message} { + debug {******* ${this}::record_test \n \ + $type $message} 3 + if {$iWarningThreshold > 0 && \ + $iWarningCnt >= $iWarningThreshold \ + || \ + $iErrorThreshold > 0 && \ + $iErrorCnt >= $iErrorThreshold} { + # Reset these first to prevent infinite recursion. + set iWarningCnt 0 + set iErrorCnt 0 + ::unresolved $message + return + } + + debug { switching on type >$type<} + switch $type { + PASS { + incr iPassCnt + } + FAIL { + incr iFailCnt + set bExitStatus 1 + } + XPASS { + incr iXPassCnt + } + XFAIL { + incr iXFailCnt + } + UNTESTED { + incr iUntestedCnt + } + UNRESOLVED { + incr iUnresolvedCnt + } + UNSUPPORTED { + incr iUnsupportedCnt + } + ERROR { + incr iErrorCnt + } + CRASHED { + incr iCrashedCnt + } + NOTE { + } + WARNING { + incr iWarningCnt + } + default { + debug {record_test called with bad type >$type<} -1 + set iErrorCnt 0 + return + } + } + + ::BlueGnu::clone_output "$type: $message" + + # reset variables here + namespace eval ::BlueGnu { + set xfail_flag 0 + set xfail_prms {} + } + } + + private method setResult {} { + if {$iUnresolved} { + set eResult UNRESOLVED + } elseif {$iPassed > 0 && $iFailed == 0} { + set eResult "PASSED" + } elseif {$iFailed} { + set eResult "FAILED" + } elseif {$iPassed == 0 && $iFailed == 0 && \ + $iUntested && $iUnsupported == 0 && \ + $iUnresolved == 0} { + set eResult ACTIVATED + } else { + set eResult UNKNOWN + } + } + + public method reportTestResult {eTestResult} { + switch $eTestResult { + "PASSED" { + incr iPassed + } + "FAILED" { + incr iFailed + } + "UNSUPPORTED" { + incr iUnsupported + } + "UNTESTED" { + incr iUntested + } + "UNRESOLVED" { + incr iUnresolved + } + } + setResult + } + + public method saveEnv {} { + global env + + set bSaved 1 + foreach index [lsort [array names env]] { + debug {ENV($index) := $env($index)} 5 + #set ENV($index) $env($index) + array set ENV [list $index $env($index)] + } + } + + public method clearEnv {} { + global env + + set bSaved 1 + #debug {removing ENV} 5 + #catch {unset ENV} + foreach index [array names env] { + debug {removing env($index) := $env($index)} 5 + if {0 > [lsearch -exact $defaultEnvironment $index]} { + debug { removed} 5 + unset env($index) + } else { + debug { kept} 5 + if {[string compare $index PATH] == 0} { + # Do not touch PATH + #set env(PATH) \ + "/etc:/usr/lib:/usr/ucb:/bin:/usr/bin:/usr/bin/X11:/usr/lpp/X11/Xamples/bin:/usr/local/bin" + } + #set ENV($index) $env($index) + } + } + } + + public method restoreEnv {} { + global env + + if {$bSaved} { + catch {unset env} + foreach index [array names ENV] { + debug {env($index) := $ENV($index)} 5 + #set ENV($index) $env($index) + array set env [list $index $ENV($index)] + } + } else { + debug {Environment had not been saved!} + } + } + + public method runTest args { + global nspTestSuite + debug {======= runTest $args} 3 + + set iRuntest 0 + set elResult [list] + + set iRun 0 + foreach arg $args { + debug {======= runTest $arg} 3 + incr iRun + + # Create name for namespace for the test + # and check if already exist + # + set szRuntest runtest$iRuntest + set namespaceCurrent [namespace current] + debug { szRuntest: >$szRuntest<} 4 + debug { namespace current : >$namespaceCurrent<} 4 + debug { namespace current children:\ + >[namespace children $namespaceCurrent]<} 4 + while {[string compare \ + [namespace children $namespaceCurrent \ + ${namespaceCurrent}::$szRuntest] ""] != 0} { + incr iRuntest + set szRuntest runtest$iRuntest + } + # now we have a unique namespace name for the running + # of the test + # + debug { runTest namespace: >$szRuntest<} 4 + set szScript $arg + # create a Test Class object + if {! [catch {::BlueGnu::Test [${nspTestSuite}::autoTest] \ + $szScript} testObject]} { + if [catch { + uplevel #0 set objCurrentTest \ + [namespace current]::$testObject + debug {[join [$testObject <<] "\n"]} 9 + namespace eval $szRuntest { + if [catch {[uplevel set testObject] runtest} \ + szErrMsg] { + uplevel set szErrMsg "\{$szErrMsg\}" + uplevel { + global errorInfo errorCode + record_test CRASHED ">$szErrMsg<\ + \n in script: >$szScript<\ + \n errorInfo: >$errorInfo<\ + \n errorCode: >$errorCode<" + } + } + } + debug {[join [$testObject <<] "\n"]} 9 + uplevel "lappend elResult [$testObject getResult]" + delete object $testObject + } szErrMsg] { + global errorInfo errorCode + record_test CRASHED ">$szErrMsg<\ + \n in script: >$szScript<\ + \n errorInfo: >$errorInfo<\ + \n errorCode: >$errorCode<" + } + } else { + global errorInfo errorCode + record_test CRASHED ">$testObject<\ + \n in script: >$szScript<\ + \n errorInfo: >$errorInfo<\ + \n errorCode: >$errorCode<" + } + namespace delete $szRuntest + uplevel #0 {debug {argv: [set argv]} 3} + } + if {$iRun == 0} { + warning "No tests have been passed to runTest method!" + } + return $elResult + } + + public method << {} { + debug {in $this method} 5 + eval [info function Common::<< -body] + #lappend lResult [list ENV [array get ENV]] + } + } + + # The following is a class definition for the target implementation + # in DejaGnu (see lib/target.exp for more detail) + # + class Target { + inherit Common + + protected variable szID + protected variable szName + protected variable szApplication + protected variable objEnvironment + protected variable objQueue + + protected variable connect + protected variable target + protected variable serial + protected variable netport + protected variable baud + protected variable X10 + protected variable ioport + + protected variable fileid + protected variable prompt + protected variable abbrev + protected variable config + protected variable cflags + protected variable ldflags + + protected variable X + + # a hairy pattern to recognize text + common text "\[- A-Za-z0-9\.\;\"\_\:\'\`\(\)\!\#\=\+\?\&\*]" + + + constructor {args} { + eval [info function Common::constructor -body] + } + + destructor { + delete object $objQueue + } + + public method name {args} { + if {[llength $args] == 0} { + return $szName + } else { + set szName [lindex $args 0] + } + } + + public method ID {args} { + if {[llength $args] == 0} { + return $szID + } else { + set szID [lindex $args 0] + } + } + + public method << {} { + eval [info function Common::<< -body] + } + + public method environment {} { + return $objEnvironment + } + + public method start {} { + if {[string length [uplevel #0 info procs ${szID}_start]] != 0} { + uplevel #0 ${szID}_start + } + } + + public method load {args} { + if {[string length [uplevel #0 info procs ${szID}_load]] != 0} { + eval uplevel #0 ${szID}_load $args + } + } + + public method exit {} { + if {[string length [uplevel #0 info procs ${szID}_exit]] != 0} { + uplevel #0 ${szID}_exit + } + } + + public method version {} { + if {[string length [uplevel #0 info procs ${szID}_version]] != 0} { + uplevel #0 ${szID}_version + } + } + + public method runTests {} { + debug {======= ${this}::runTest} 3 + set elResult [list] + # if an application has been defined we run all the test + # inside that application + # + if {[string compare [info variable szApplication] ""] != 0 && \ + [string compare [info variable szApplication -value] \ + "<undefined>"] != 0} { + debug {Application specified >[info variable \ + szApplication -value]<} + # build argument list + debug {>>[<<]<<} + } else { + # We just run all the tests in the currently running + # [incr Tcl/?Expect?] interpreter. + # + # set the current Queue and Environment + # + uplevel #0 set objCurrentQueue [infoWhich $objQueue] + uplevel #0 set objCurrentEnvironment \ + [infoWhich $objEnvironment] + # + # Pop a test from the queue and run it in the environment + ::BlueGnu::clone_output "###########################" + ::BlueGnu::clone_output "####### Begin test session:\ + [[infoWhich $objEnvironment] name] >$objEnvironment<" + while {! [catch {$objQueue pop} T]} { + debug {test: $T} 3 + set elResult [$objEnvironment runTest $T] + } + ::BlueGnu::clone_output "####### End test session :\ + [[infoWhich $objEnvironment] name]" + } + return $elResult + } + + public method queue {function element} { + switch $function { + append { + $objQueue append $element + } + prepend { + $objQueue prepend $element + } + } + } + } + + class Target2 { + inherit Target + + protected variable XYZ + + constructor {args} { + eval [info function Common::constructor -body] + } + + public method << {} { + eval [info function Common::<< -body] + } + } + + + class DejaGnu { + inherit Environment + + constructor {} { + debug {Level in Constructor DejaGnu: [info level]} 9 + uplevel #0 {debug {argc = $argc: $argv} 9} + # source always in global space + # + uplevel #0 source {$env(BLUEGNULIBS)/dejagnu.tcl} + } + + destructor { + ##################################################################### + # This comes from the original runtest + # all done, cleanup + # + uplevel #0 { + if { [info procs ${tool}_exit] != "" } { + if {[catch "${tool}_exit" tmp]} { + # ??? We can get away with calling `warning' + # here without ensuring + # `warncnt' isn't changed because we're about to exit. + warning "${tool}_exit failed:\n$tmp" + } + } + log_summary + } + } + + + public method runTest {args} { + global nspTestSuite + + foreach arg $args { + debug {******* DejaGnu running test: >$arg<} + debug {set szTestName \[Test \[${nspTestSuite}::autoTest\] $arg\]} 3 + debug {set testName >[${nspTestSuite}::autoTest]<} 3 + uplevel #0 set szTestName [Test [${nspTestSuite}::autoTest] $arg] + uplevel #0 { + debug $szTestName 3 + debug [join [$szTestName <<] "\n"] 5 + set test_name {[$szTestName scriptName]} + catch {unset tmp}; set tmp {} + foreach arg [$szTestName arguments] { + lappend tmp [join $arg "="] + } + set runtests [list [$szTestName name] $tmp] + debug {args = >[$szTestName arguments]<} 3 + source [$szTestName scriptName] + catch {eval unset [info vars __*]} + } + } + } + } + + class DejaGnu2 { + inherit DejaGnu + + protected variable currentTool + + constructor {} { + debug {Level in Constructor DejaGnu2: [info level]} 9 + set currentTool {} + uplevel #0 {debug {argc = $argc: $argv} 9} + # source always in global space + # + uplevel #0 source {$env(BLUEGNULIBS)/dejagnu2.tcl} + } + + public method tool {args} { + if {[llength $args] == 1} { + set currentTool [lindex $args 0] + } + return $currentTool + } + } + + class Benchmark { + protected variable bResult 0 + protected variable DATA + protected variable FORMAT + protected variable ARG + + protected constructor {args} { + debug {======= Constructing class [info class] =======} 3 + debug {======= ::BlueGnu::Benchmark::constructor $args} 4 + set i 0 + foreach arg $args { + debug { ARG($i): >$arg<} 5 + set ARG($i) [split $arg "="] + incr i + } + } + protected destructor { + debug {======= [info class]::destructor} 3 + } + + protected method benchmark {benchmarkFunction args} { + warning "Method >benchmark< has not been implemented for\ + Class >[info class]<" + return $bResult + } + + protected method warningNoBenchmarkArguments {} { + warning "NO argument have been supplies for\n the benchmark\ + method in class [info class]" + } + protected method warningNoBenchmarkFunction {} { + warning "NO benchmark function >[uplevel set benchmarkFunction]<\ + defined for\n the benchmark method in class [info class]" + } + } + + class Error { + private variable _errorCode + private variable _errorMsg + private variable _errorInfo + + public constructor {errorCode errorMsg errorInfo} { + set _errorCode $errorCode + set _errorMsg $errorMsg + set _errorInfo $errorInfo + } + + public method errorCode {} { + return $_errorCode + } + public method errorMsg {} { + return $_errorMsg + } + public method errorInfo {} { + return $_errorInfo + } + public method why {} { + return $_errorMsg + } + public method verboseWhy {} { + return $_errorInfo + } + } +} diff --git a/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl b/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl new file mode 100644 index 0000000..7f96880 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/testSessionFramework.itcl @@ -0,0 +1,1386 @@ +# +# +# +# +# unknown -- called by expect if a proc is called that doesn't exist +# + +# Set auto_load to take BLUEGNULIB first on search path +# +set auto_path "$env(BLUEGNULIB) $auto_path" + +# find tclIndex file in the test suite directory structure +# $env(TESTSUITEROOT) and in the path up to the root +# +if {! [info exists env(TESTSUITEROOT)]} { + set env(TESTSUITEROOT) [exec /bin/sh -c pwd] +} +set PWD $env(TESTSUITEROOT) + +if {[info exists env(TESTSETS)]} { + if {[lsearch -exact [split $env(TESTSETS) ":"] $PWD] < 0} { + set env(TESTSETS) $PWD:$env(TESTSETS) + } +} else { + set env(TESTSETS) $PWD +} +cd $PWD + + +# First thing to do is calculate the verbose level and the debug flag +# as well as the definition of the associated procedures: +# verbose and debug. +# +# Check the Debug level +if [info exists env(DEBUG)] { + switch -regexp [string toupper $env(DEBUG)] { + 1 - ^T(R(U(E)?)?)?$ - ^Y(E(S)?)?$ { + set bDebug 1 + } + default { + set bDebug 0 + } + } +} else { + set bDebug 0 +} + +# Calculate verbose level +# Complete a first path over the argument list +# Calculate the Verbose Level +set verbose 0 +foreach __arg $argv { + switch -regexp -- $__arg { + {^-[-]?v(e(r(b(o(s(e)?)?)?)?)?)?$} { + incr verbose + } + default { + lappend __lArgs $__arg + } + } +} +if {[catch {set argv $__lArgs}]} { + set argv {} +} + +# Define the procedures: verbose & debug +# +# verbose [-n] [-log] [--] message [level] +# +# Print MESSAGE if the verbose level is >= LEVEL. +# The default value of LEVEL is 1. +# "-n" says to not print a trailing newline. +# "-log" says to add the text to the log file even if it won't be printed. +# Note that the apparent behaviour of `send_user' dictates that if the message +# is printed it is also added to the log file. +# Use "--" if MESSAGE begins with "-". +# +# This is defined here rather than in framework.exp so we can use it +# while still loading in the support files. +# +proc verbose {args} { + debug {======= verbose $args} 3 + global verbose + + set newline 1 + set logfile 0 + + set i 0 + if {[string index [lindex $args 0] 0] == "-"} { + for { set i 0 } { $i < [llength $args] } { incr i } { + if { [lindex $args $i] == "--" } { + incr i + break + } elseif { [lindex $args $i] == "-n" } { + set newline 0 + } elseif { [lindex $args $i] == "-log" } { + set logfile 1 + } elseif { [string index [lindex $args $i] 0] == "-" } { + return [::BlueGnu::clone_output "ERROR: verbose:\ + illegal argument: [lindex $args $i]"] + } else { + break + } + } + } + if {[llength $args] == $i} { + return [::BlueGnu::clone_output "ERROR: verbose: nothing to print"] + } + + + set level 1 + if {[llength $args] == $i + 2} { + if [catch {set level [expr [lindex $args [expr $i+1]]]} szErrMsg] { + return [::BlueGnu::clone_output "ERROR: verbose: level number\ + >$szErrMsg<"] + } + } elseif {[llength $args] > $i + 2} { + return [::BlueGnu::clone_output "ERROR: verbose: Too many arguments"] + } + set message [lindex $args $i] + + if {$level <= $verbose} { + # There is no need for the "--" argument here, but play it safe. + # We assume send_user also sends the text to the log file (which + # appears to be the case though the docs aren't clear on this). + if 0 { + if {[string compare \ + [namespace eval ::BlueGnu \ + {set ::BlueGnu::sum_file}] stdout] != 0} { + set szCmd [list uplevel puts [namespace eval ::BlueGnu \ + {set ::BlueGnu::sum_file}]] + lappend szCmd "\"$message\"" + debug {==## 1 >$szCmd<} 9 + if {[catch {eval $szCmd}]} { + puts [namespace eval ::BlueGnu \ + {set ::BlueGnu::sum_file}] $message + } + } + } + if [catch {set message \ + "[uplevel set __szTmp \"$message\"]"} szErrMsg] { + set message "$message == ERROR: >$szErrMsg<" + } + if {$newline} { + #append message "\n" + } + debug {$message} 0 + return [::BlueGnu::clone_output "$message"] + } elseif {$logfile} { + if [catch {set message \ + "[uplevel set __szTmp \"$message\"]"} szErrMsg] { + set message "$message == ERROR: >$szErrMsg<" + } + if {$newline} { + append message "\n" + } + debug {$message} 0 + return [send_log $message] + } + return "" +} + +if {$bDebug} { + proc debug {text {level 1}} { + global verbose + + if {$level <= $verbose} { + set szCmd [list uplevel ::BlueGnu::clone_output] + set szA $level; set iMax [uplevel info level] + for {set i 0} {$i < $iMax} \ + {incr i} {append szA ">"} + lappend szCmd "\"$szA$text\"" + eval $szCmd + } + } +} else { + proc debug {text {level 1}} { + } +} + +# This procedure will find a file in the directory structure +# any where below the current working directory +# any where on the search path +# or up the directory tree +# +proc locateFile {szFileName {szSubDirectory "."}} { + debug {======= locateFile $szFileName $szSubDirectory} 3 + global env + # remove a trailing "/" from sub directory name + regexp {(.*)/$} $szSubDirectory dummy szSubDirectory + + set newList {} + set searchList {.} + set tmpDir [pwd] + while {[string compare [set dir [file dirname $tmpDir]] "/"] != 0} { + lappend searchList $dir + set tmpDir $dir + } + foreach dir [split $env(TESTSETS) ":"] { + lappend searchList $dir + } + foreach dirList $searchList { + foreach test [searchForFile $szFileName $dirList $szSubDirectory] { + # only files that are readable and + # not a directory, symbolic link or device + # are added to the list + if {[file isfile $test] && [file readable $test]} { + # add only if not already exists in list + if {[lsearch -exact $newList $test] < 0} { + lappend newList $test + } + } + } + } + debug {======= returning newList: >$newList<} 4 + return $newList +} + +proc locateDir {szFileName {szSubDirectory "."}} { + debug {======= locateDir $szFileName $szSubDirectory} 3 + global env + # remove a trailing "/" from sub directory name + regexp {(.*)/$} $szSubDirectory dummy szSubDirectory + + set newList {} + set searchList {.} + set tmpDir [pwd] + while {[string compare [set dir [file dirname $tmpDir]] "/"] != 0} { + lappend searchList $dir + set tmpDir $dir + } + foreach dir [split $env(TESTSETS) ":"] { + lappend searchList $dir + } + foreach dirList $searchList { + foreach test [searchForFile $szFileName $dirList $szSubDirectory] { + # only files that are directories + # are added to the list + if {[file isdirectory $test]} { + # add only if not already exists in list + if {[lsearch -exact $newList $test] < 0} { + lappend newList $test + } + } + } + } + debug {======= returning newList: >$newList<} 4 + return $newList +} + +proc searchForFile {szFileName dirList szSubDirectory} { + debug {======= searchForFile $szFileName $dirList $szSubDirectory} 3 + # find sub directory in or below the current working directory + set szDirSrc "" + foreach file [file split $szSubDirectory] { + if {[string compare $file "."] == 0} { + if {! [info exists newList]} { + set newList {} + } + continue + } else { + foreach dir $dirList { + catch {unset newList} + foreach newDir [findFile $dir $file] { + lappend newList $newDir + } + } + } + if {[catch {set dirList $newList}]} { + set dirList {} + } + } + debug { dirList = >$dirList<} 4 + set fileList {} + foreach dir $dirList { + set newList [findFile $dir $szFileName] + if {[llength $newList] > 0} { + set fileList [concat $fileList $newList] + } + } + debug { fileList = >$fileList<} 4 + if {[llength $fileList] != 0} { + # NO test found, next step in searching + #return $fileList + } + + set newList {} + set PWD [pwd] + foreach dir $fileList { + debug { dir = >$dir<} 4 + cd [file dirname $dir] + lappend newList "[pwd]/[file tail $dir]" + cd $PWD + } + + debug { newList = >$newList<} 4 + return $newList +} + +proc findFile {szDirectory szFileName} { + global locatedFile env + + debug {======= findFile $szDirectory $szFileName} 3 + if {! [info exists locatedFile($szDirectory/$szFileName)]} { + if {[file readable $szDirectory/$szFileName]} { + set locatedFile($szDirectory/$szFileName) $szDirectory/$szFileName + } else { + if {$szDirectory == "." || \ + [lsearch -exact [split $env(TESTSETS) ":"] \ + $szDirectory] >= 0} { + set locatedFile($szDirectory/$szFileName) \ + [split [exec find $szDirectory -name $szFileName \ + -print] "\n"] + } else { + return {} + } + } + } + return $locatedFile($szDirectory/$szFileName) +} + +# appendArguments +# +# This procedure will append the string pathed in arguments to every +# element of fileList +# return a list with the same number of element in which each +# element has the arguments appended +# +proc appendArguments {fileList arguments} { + set newList {} + debug {======= appendArguments $fileList $arguments} 3 + debug { length argument list: >[llength $arguments]<} 4 + if {[string length $arguments] > 0} { + foreach file $fileList { + regexp {([^[=]+)([[][^]]*[]])?(.*)} $file dummy szT szID szA + debug {dummy: >$dummy<} 4 + debug {szT : >$szT<} 4 + if {[string length $szID] > 0} { + #regexp {[[]([^]]+)[]]} $szID dummy szID + } + debug {szID : >$szID<} 4 + if {[string length $szA] > 0} { + regexp {=(.*)} $szA dummy szA + } + debug {szA : >$szA<} 4 + #set lFile [split $file "="] + if {[string length $szA] > 0} { + set szSep " " + } else { + set szSep "=" + } + lappend newList ${file}${szSep}$arguments + } + return $newList + } + return $fileList +} + +# appendTestCaseID +# +# This procedure will append the string pathed in arguments to every +# element of fileList +# return a list with the same number of element in which each +# element has the arguments appended +# +proc appendTestCaseID {fileList {szTestCaseID ""}} { + set newList {} + debug {======= appendTestCaseID $fileList >$szTestCaseID<} 3 + set bMultiFiles [expr [llength $fileList] > 1] + set i 1 + foreach file $fileList { + regexp {([^[=]+)([[][^]]*[]])?(.*)} $file dummy szT szID szA + debug {dummy: >$dummy<} 4 + debug {szT : >$szT<} 4 + if {[string length $szID] > 0} { + regexp {[[]([^]]+)[]]} $szID dummy szID + } + debug {szID : >$szID<} 4 + if {[string length $szA] > 0} { + #regexp {=(.*)} $szA dummy szA + } + debug {szA : >$szA<} 4 + if {[string length $szID] > 0} { + set szID [string trim "${szID}${szTestCaseID}"] + } else { + set szID ${szTestCaseID} + } + if {[llength [split $szID "="]] > 1} { + set szSep " " + } else { + set szSep "=" + } + if {[string length $szID] == 0} { + lappend newList "${szT}$szA" + continue + } + if {$bMultiFiles} { + set szI [format "${szSep}seqNr=%03d" $i] + } else { + set szI "" + } + lappend newList "${szT}\[${szID}${szI}\]$szA" + incr i + } + return $newList +} + +# processArgs +# +# This procedure expect all optional arguments to be name=value pairs +# It will set all variable named to the value given within +# the procedure body +# It will return an empty list or a list of all remaining not name=value +# pair in the argument list +# +proc processArgs {args} { + debug {======= processArgs $args} 3 + + set llArgs $args + set args {} + + # set default errorCode=NONE + uplevel set errorCode NONE + # now process all name=value pair arguments + ####### There may be a better way to do this see pre 8.0 code + foreach lArgs $llArgs { + foreach arg $lArgs { + set NVP [split $arg "="] + if {[llength $NVP] > 1} { + debug {uplevel set [lindex $NVP 0] \ + [list [join [lrange $NVP 1 end] "="]]} 3 + uplevel set [lindex $NVP 0] \ + [list [join [lrange $NVP 1 end] "="]] + } else { + lappend args $arg + } + } + } + debug { processArgs returns: $args} 3 + return $args +} + +# processInternalArgs +# +# This procedure expect all optional arguments to be {name value} pairs +# It will set all variable named to the value given within +# the procedure body +# It will return an empty list or a list of all remaining not name=value +# pair in the argument list +# +proc processInternalArgs {lArgs} { + debug {======= processInternalArgs $lArgs} 3 + set arglist {} + + # set default errorCode=NONE + uplevel set errorCode NONE + # now process all {name value} pair arguments + foreach arg $lArgs { + if {[llength $arg] == 2} { + debug {uplevel set [lindex $arg 0] \ + [list [join [lrange $arg 1 end] "="]]} 3 + uplevel set [lindex $arg 0] \ + [list [join [lrange $arg 1 end] "="]] + } else { + lappend arglist $arg + } + } + debug {processInternalArgs returns: $arglist} 3 + return $arglist +} + +# processTestScriptArgs +# +# This procedure expect all optional arguments to be {name value} pairs +# It will set all variable named to the value given within +# the procedure body +# It will return an empty list or a list of all remaining not name=value +# pair in the argument list +# +# This is a copy of the procedure "processInternalArgs" without an argument +# however this procedure may become different +# +# +proc processTestScriptArgs {} { + upvar lArgs lArgs + set arglist {} + + # set default errorCode=NONE + uplevel set errorCode NONE + debug {======= processTestScriptArgs $lArgs} 3 + # now process all {name value} pair arguments + foreach arg $lArgs { + if {[llength $arg] == 2} { + debug {uplevel set [lindex $arg 0] \ + [list [join [lrange $arg 1 end] "="]]} 4 + uplevel set [lindex $arg 0] \ + [list [join [lrange $arg 1 end] "="]] + } else { + lappend arglist $arg + } + } + debug { processInternalArgs returns: $arglist} 4 + return $arglist +} + +# Command execution command +# This command is like the catch command, however it can do some additional +# testing and in case of an error it will return a error class. +# +proc doCmd {szCmd args} { + global errorInfo errorCode + if {! [info exists errorInfo]} { + set errorInfo "<errorInfo has not been defined>" + } + + debug {======= doCmd >$szCmd< >$args<} 3 + foreach arg $args { + set vv [split $arg "="] + if {[llength $vv] == 2} { + debug { ==>> Expected value: [lindex $vv 0]=[eval list \ + [lindex $vv 1]]} 5 + set [lindex $vv 0] [eval list [lindex $vv 1]] + } elseif {[llength $vv] == 1} { + if {! [info exists errorObj]} { + debug { ==>> upvar $vv errorObj} 5 + if "! [uplevel info exists $vv]" { + debug { ==>> creating: $vv (uplevel)} 5 + uplevel [list set $vv {}] + } + upvar $vv errorObj + } + } + } + if {[catch {uplevel 1 $szCmd} szErrMsg]} { + debug {======= ErrMsg : \n$szErrMsg\n======= from:\n$szCmd} 5 + set errorObj "" + if {[string compare $errorCode NONE] == 0} { + set errorCode UNDEFINED + } + set errorInfoSave $errorInfo + set errorCodeSave $errorCode + catch {set errorObj [uplevel infoWhich \{$szErrMsg\}]} + set errorInfo $errorInfoSave + set errorCode $errorCodeSave + debug { ==>> errorObj: >$errorObj<} 5 + if {[string compare $errorObj ""] == 0} { + set errorObj [uplevel \ + ::BlueGnu::Error #auto \{$errorCode\} \ + \{$szErrMsg\} \{$errorInfo\}] + debug {errorObj: >$errorObj<} 5 + set errorObj [uplevel infoWhich \{$errorObj\}] + debug {errorObj: >$errorObj<} 5 + debug {Command: [string trim $szCmd]} 5 + debug {ErrMsg : \n$szErrMsg} 5 + debug {====================} 5 + global errorInfo + debug {ErrInfo: $errorInfo\n====================} 5 + } + set bReturn 1 + if {[info exists errorCode]} { + debug { errorCode= $errorCode} 5 + debug { Class= [$errorObj info class]} 5 + catch {debug { isa BC_RTN= [$errorObj isa BC_RTN]} 5} + catch {debug { isa ERROR= [$errorObj isa Error]} 5} + catch { + if [$errorObj isa BC_RTN] { + if {[set i \ + [lsearch -exact $errorCode \ + [list [$errorObj SEVERITY] \ + [$errorObj FACILITY] [$errorObj CODE]]]] >= 0} { + setup_xfail + set bReturn 0 + } + fail "Expected errorCode=$errorCode, got:\ + [$errorObj getShortMsg]\ + \{[$errorObj SEVERITY] [$errorObj FACILITY]\ + [$errorObj CODE]\} for >$szCmd<" + #verbose { errorCode: [$errorObj errorCode]} + #verbose { why: [$errorObj why]} + #verbose {verboseWhy: [$errorObj verboseWhy]} 2 + } + } + catch { + if [$errorObj isa Error] { + debug { Error= [$errorObj errorCode]} 5 + if {[set i \ + [lsearch -exact $errorCode \ + [$errorObj errorCode]]] >= 0} { + setup_xfail + set bReturn 0 + } + fail "Expected errorCode=$errorCode, got:\ + [$errorObj errorCode] for >$szCmd<" + verbose { errorCode: [$errorObj errorCode]} + verbose { why: [$errorObj why]} + verbose {verboseWhy: [$errorObj verboseWhy]} 2 + } + } + } + return $bReturn + } else { + set bReturn 0 + set NOT "" + if {[info exists errorCode]} { + if {[lsearch -exact $errorCode "NONE"] < 0} { + setup_xfail + set NOT "not " + set bReturn 1 + } + pass "errorCode=NONE ${NOT}found in expected set\ + of errorCodes=\{$errorCode\} for >$szCmd<" + } + if {[info exists return]} { + debug {Return: >$return<} 3 + set bResult 0 + set iFalse 0 + set iFalseFound 0 + set iTrue 0 + set iTrueFound 0 + foreach lResult $return { + if {[llength $lResult] == 2} { + set bFlag [string toupper [lindex $lResult 0]] + set szResult [lindex $lResult 1] + } else { + set bFlag "" + set szResult [lindex $lResult 0] + } + debug {Checking >$szErrMsg< against $bFlag >$szResult<} 3 + switch $bFlag { + 0 - NOT - NO - FALSE { + # no matches allowed + incr iFalse + debug {Should not match >$szErrMsg< != >$szResult<} 4 + if {[string compare $szErrMsg $szResult] != 0} { + pass "The NOT Expected Result >$szResult<\ + was not found for >$szCmd<" + incr iFalseFound + } else { + fail "The NOT Expected Result >$szResult<\ + was found for >$szCmd<" + } + } + 1 - {} - YES - TRUE { + # only one match allowed + incr iTrue + debug {Should match >$szErrMsg< == >$szResult<} 4 + if {[string compare $szErrMsg $szResult] == 0} { + pass "Expected Result >$szResult<\ + found for >$szCmd<" + incr iTrueFound + } + } + default { + perror "doCmd result flag: 1, 0, <empty>,\ + NOT, YES, NO, TRUE, FALSE" + } + } + } + set bResult [expr $iFalse == $iFalseFound] + if {$iTrue > 0} { + set bResult [expr $bResult && ($iTrueFound == 1)] + } + if {! $bResult} { + fail "Expected Result(s) >$return<\n \ + did not match with: >$szErrMsg< for >$szCmd<" + set bReturn 1 + } + } + if {[info exists errorObj]} { + set errorObj $szErrMsg + } + } + return $bReturn +} + + +# deleteObjects +# +# This procedure takes multiple arguments each can be a single object +# or a list of objects +# it will delete all these object +# No return value +# +proc deleteObjects {args} { + debug {======= deleteObjects $args} 3 + foreach arg $args { + foreach object $arg { + debug " delete object >$object<" 4 + delete object $object + } + } + return {} +} + +# isObject +# This procedure accepts a fully qualified object name as argument +# and checks if that object exists +proc isObject {object} { + debug {======= isObject $object} 3 + set tmp [namespace tail $object] + return [expr [lsearch [namespace eval [namespace qualifier $object] { + ::itcl::find objects + } + ] $tmp] >= 0] +} + +# checkObject +# This procedure takes an object and a class name is argument +# It checks if the object exists, has a counter part in C++ and +# is of the correct class +# +proc checkObject {object szClassName} { + debug {======= checkObject $object $szClassName} 3 + if {! [catch { + set class [uplevel "$object info class"] + if {[catch {[findObject $object] isa $szClassName} bCl]} { + if {[string compare [namespace tail $class] \ + [namespace tail $szClassName]] == 0} { + debug {Class [namespace tail $szClassName]\ + match class of object} 4 + } else { + error "Miss match" + } + } elseif {! $bCl} { + error 1 + } + } iRet]} { + return 1 + } + + set obj [findObject $object] + set class [findClass $szClassName] + if {[string length $obj] > 0 && [string length $class] > 0} { + debug { ==>> object and class passed do exists} 4 + if {[catch {set bISA [$obj isa $class]}]} { + debug {Class $szClassName is not inscope to match $object} 4 + return 0 + } + if {! $bISA} { + debug {$object is not of Class $szClassName} 4 + return 0 + } + } else { + debug {$object and/or $szClassName have not been found!} 4 + return 0 + } + return 1 +} + +# findObject +# This procedure take the name of an object, possibly without any qualifier +# and search all namespaces to find the object. +# When a qualifier is specified, it will check if it is complete +# The procedure return the fully qualified name of the object if it exists or +# an empty string otherwise. +# +proc findObject {object {namespace ::}} { + debug {======= findObject $object $namespace} 3 + set ns [namespace qualifier $object] + set obj [namespace tail $object] + set objs [namespace eval $namespace {::itcl::find objects}] + if {[lsearch $objs $obj] >= 0} { + regsub "::$" $namespace "" namespace + return ${namespace}::$obj + } else { + set result "" + foreach cns [namespace children $namespace] { + set result [findObject $obj $cns] + if {[string length $result] > 0} break + } + } + return $result +} + +# findClass +# This procedure take the name of an class, possibly without any qualifier +# and search all namespaces to find the class. +# When a qualifier is specified, it will check if it is complete +# The procedure return the fully qualified name of the Class if it exists or +# an empty string otherwise. +# +proc findClass {class {namespace ::}} { + debug {======= findClass $class $namespace} 3 + set ns [namespace qualifier $class] + set obj [namespace tail $class] + set objs [namespace eval $namespace {::itcl::find classes}] + if {[lsearch $objs $obj] >= 0} { + regsub "::$" $namespace "" namespace + return ${namespace}::$obj + } else { + set result "" + foreach cns [namespace children $namespace] { + set result [findClass $obj $cns] + if {[string length $result] > 0} break + } + } + return $result +} + +# The parseTest command will validate the argument as an existing +# test including testCaseID and arguments. +# It will return a list of all acceptable test script +# +proc parseTest {args} { + global szCurrentTestDirectory + debug {======= parseTest $args} 3 + + foreach arg $args { + foreach szTest $arg { + regexp {([^[=]+)([[][^]]*[]])?(.*)} $szTest dummy szT szID szA + debug {dummy: >$dummy<} 4 + debug {szT : >$szT<} 4 + if {[string length $szID] > 0} { + #regexp {[[]([^]]+)[]]} $szID dummy szID + } + debug {szID : >$szID<} 4 + if {[string length $szA] > 0} { + #regexp {=(.*)} $szA dummy szA + } + debug {szA : >$szA<} 4 + set szFileName $szT + set szDname [file dirname $szFileName] + set szFname [file tail $szFileName] + + if {[file exist [set test [file join \ + $szCurrentTestDirectory \ + $szFileName]]]} { + # file should be a test + debug { is a test: >$test<!} 3 + lappend testList [file join $szCurrentTestDirectory $szTest] + } elseif {[llength [set tests \ + [locateFile $szFname $szDname]]] > 0} { + foreach test $tests { + if {[file exists $test]} { + # file should be a test + debug { is a test: >$test<!!} 3 + lappend testList ${test}${szID}${szA} + } else { + warning "Test >$test< can't be found" + } + } + } else { + perror "$szFileName is not a test!\ + Does not exists!" + } + } + } + if [info exists testList] { + if [llength $testList] { + return $testList + } + } + return [list] +} + +# The global available runtest procedure +# this procedure will find the current environment +# and execute the runTest procedure in that environment + +proc runtest {args} { + global objCurrentEnvironment szCurrentTestDirectory + debug {======= runtest $args} 3 + set elResult [list] + + if {[llength $args] > 0} { + set Env [lindex $args 0] + debug { Checking for environment: >$Env<} 3 + debug { >[infoWhich $Env]<} 5 + debug { Current Test Directory: >$szCurrentTestDirectory<} 5 + if {[string compare [infoWhich $Env] ""] == 0} { + debug { not an environment} 4 + if {[info exist objCurrentEnvironment] && \ + [string compare \ + [infoWhich $objCurrentEnvironment] ""] != 0} { + debug { Found Current Environment\ + >$objCurrentEnvironment<} 5 + set Env $objCurrentEnvironment + } else { + error "NO default environent" + } + } else { + debug { is an environment} 3 + set args [lrange $args 1 end] + } + set T [lindex $args 0] + set A [lindex $args 1] + set I [lindex $args 2] + foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] { + debug { ==>> $objCurrentEnvironment\ + runTest $t} 3 + lappend elResult \ + [$Env runTest $t] + } + } else { + warning "No tests have been passed to runtest procedure!" + } + return $elResult +} + +proc appendQueue {args} { + global objCurrentQueue szCurrentTestDirectory + debug {======= appendQueue $args} 3 + + set iRun 0 + set Queue [lindex $args 0] + if {[string compare [infoWhich $Queue] ""] == 0} { + if {[info exist objCurrentQueue]} { + set Queue $objCurrentQueue + } else { + error "NO default queue" + } + } else { + set args [lrange $args 1 end] + } + set T [lindex $args 0] + set A [lindex $args 1] + set I [lindex $args 2] + foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] { + debug { ==>> $Queue append $t} 3 + incr iRun + $Queue append $t + } + if {$iRun == 0} { + warning "NO argument to appendQueue have been processed" + } +} + +proc prependQueue {args} { + global objCurrentQueue szCurrentTestDirectory + debug {======= prependQueue $args} 3 + + set iRun 0 + set Queue [lindex $args 0] + if {[string compare [infoWhich [lindex $args 0]] ""] == 0} { + if {[info exist objCurrentQueue]} { + set Queue $objCurrentQueue + } else { + error "NO default queue" + } + } else { + set args [lrange $args 1 end] + } + set T [lindex $args 0] + set A [lindex $args 1] + set I [lindex $args 2] + foreach t [appendTestCaseID [appendArguments [parseTest $T] $A] $I] { + incr iRun + lappend comList $t + } + debug { ==>> $Queue prepend $comList} 3 + eval $Queue prepend $comList + + if {$iRun == 0} { + warning "NO argument to appendQueu have been processed" + } +} + +proc perror {args} { + global errorInfo + global objCurrentTest + global objCurrentEnvironment + + # save errorInfo + set errorInfoSave $errorInfo + + if { [llength $args] > 1 } { + set $::BlueGnu::errcnt [lindex [uplevel set args] 1] + } else { + incr ::BlueGnu::errcnt + } + + while 1 { + set szMsg [lindex $args 0] + + if {[catch {$objCurrentTest perror $szMsg} \ + szErrMsg]} { + if {[info exists objCurrentTest]} { + debug {No current test: >$szErrMsg<:\ + current test >$objCurrentTest< message:\n \ + $szMsg} 3 + } else { + debug {PERROR: No current test: >$szErrMsg<:\ + current test >DOES NOT EXIST< message:\n \ + $szMsg} 3 + debug { info: >>>$errorInfo<<<} 4 + } + } else { + break + } + catch { + set szCmd [concat \"$objCurrentEnvironment\" record_test \ + ERROR \$szMsg] + } + if {[catch {eval $szCmd} szErrMsg]} { + verbose {No current environment (ERROR): >$szErrMsg<} 3 + } else { + break + } + + ::BlueGnu::clone_output "ERROR: $szMsg" + namespace eval ::BlueGnu { + set errno "ERROR: [uplevel set szMsg]" + } + break + } + + # restore errorInfo + set errorInfo $errorInfoSave +} + +proc warning {args} { + global errorInfo + global objCurrentTest + global objCurrentEnvironment + + # save errorInfo + set errorInfoSave $errorInfo + + if { [llength $args] > 1 } { + namespace eval ::BlueGnu { + set warncnt [lindex [uplevel set args] 1] + } + } else { + namespace eval ::BlueGnu { + incr warncnt + } + } + + while 1 { + set szMsg [lindex $args 0] + + if {[catch {$objCurrentTest warning $szMsg} \ + szErrMsg]} { + if {[info exists objCurrentTest]} { + verbose {No current test: >$szErrMsg<:\ + current test >$objCurrentTest< message:\n \ + $szMsg} 3 + } else { + verbose {WARNING: No current test: >$szErrMsg<:\ + current test >DOES NOT EXIST< message:\n \ + $szMsg} 3 + } + } else { + break + } + catch { + set szCmd [concat \"$objCurrentEnvironment\" record_test \ + WARNING \$szMsg] + } + if {[catch {eval $szCmd} szErrMsg]} { + verbose {No current environment (WARNING): >$szErrMsg<} 3 + } else { + break + } + + set szMsg [lindex $args 0] + ::BlueGnu::clone_output "WARNING: $szMsg" + namespace eval ::BlueGnu { + set errno "WARNING: [uplevel set szMsg]" + } + break + } + if 0 { + uplevel #0 { + verbose {uplevel #0 to remove errorInfo} + if [info exists errorInfo] { + unset errorInfo + } + } + } + # restore errorInfo + set errorInfo $errorInfoSave +} + +proc note {szMsg} { + global objCurrentTest + + $objCurrentTest note $szMsg +} + +proc pass {szMsg} { + global objCurrentTest + + $objCurrentTest pass $szMsg +} + +proc fail {szMsg} { + global objCurrentTest + + $objCurrentTest fail $szMsg +} + +proc unresolved {szMsg} { + global objCurrentTest + + $objCurrentTest unresolved $szMsg +} + +proc untested {szMsg} { + global objCurrentTest + + $objCurrentTest untested $szMsg +} + +proc unsupported {szMsg} { + global objCurrentTest + + $objCurrentTest unsupported $szMsg +} + +proc get_warning_threshold {} { + return [namespace eval ::BlueGnu {set warning_threshold}] +} + +proc set_warning_threshold {threshold} { + namespace eval ::BlueGnu { + set warning_threshold [uplevel set threshold] + } +} + +proc setup_xfail {args} { + namespace eval ::BlueGnu {set xfail_flag 1} +} + +proc clear_xfail {args} { + namespace eval ::BlueGnu {set xfail_flag 0} +} + +proc benchmark {benchmarkFunction args} { + debug {======= benchmark $benchmarkFunction $args} + global objCurrentTest + global errorInfo + + if 0 { + debug {[foreach var [info vars] { + verbose {local var: >$var<}}] + } + uplevel { + debug {[foreach var [info vars] { + verbose {uplevel local var: >$var<}}] + } + } + debug {[foreach var [info globals] { + verbose {global var: >$var<}}] + } + } + + set errorInfo "" + set szID [$objCurrentTest ID] + set szTestCaseID [$objCurrentTest testCaseID] + set benchmarkObject [$objCurrentTest benchmarkObject] + set benchmarkClassName [$objCurrentTest benchmarkClassName] + debug { ==>> test ID: >$szID<} 3 + debug { test case ID: >$szTestCaseID<} 3 + debug { check test object: >$benchmarkObject<} 3 + if {$benchmarkObject == ""} { + warning "NO Benchmark Class defines for >$benchmarkClassName<" + set bResult 0 + } else { + if [catch { + set bResult [eval $benchmarkObject benchmark \ + $benchmarkFunction $args] + } errMsg] { + warning "NO checking has been done for\ + ${benchmarkClassName}::benchmark $benchmarkFunction $args" + debug {[perror "BenchmarkFunction: >$benchmarkFunction<\ + has not been defined\ + in class $benchmarkClassName\n### Error Msg: $errMsg"]} 0 + debug {### Error Info: $errorInfo} 0 + set bResult 0 + } + } + return $bResult +} + +proc envPATH {szAction szDir} { + debug {======= envPATH $szAction $szDir} 3 + + global env + if [file isdirectory $szDir] { + # remove directory from Path if it exists + set envPATH $env(PATH) + while {[regsub :?$szDir:? $envPATH {:} envPATH]} { + } + regsub {^:} $envPATH {} envPATH + regsub {:$} $envPATH {} envPATH + set env(PATH) $envPATH + switch $szAction { + prefix - + prepend { + set env(PATH) "$szDir:$env(PATH)" + } + append { + append env(PATH) ":$szDir" + } + default { + } + } + } +} + +# replacement for info which commaond +# +proc infoWhich {name {namespace ::}} { + debug {======= infoWhich $name $namespace} 3 + if [catch {uplevel set infoWhich__name $name} szErrMsg] { + debug { error: $szErrMsg} + return "" + } + uplevel { + debug { objects: >[::itcl::find objects]<} 4 + debug { namespace: >[namespace current]<} 4 + infoWhichYYY + } + set name [uplevel set infoWhich__name] + uplevel unset infoWhich__name + debug {infoWhich return: >$name<} 4 + return $name +} +proc infoWhichXXX {} { + uplevel { + set i [lsearch -regexp [::itcl::find objects] "[namespace tail \ + $infoWhich__name]"] + if {$i < 0} { + set infoWhich__name "" + } else { + set infoWhich__name [lindex [::itcl::find objects] $i] + if {! [string match ::* $infoWhich__name]} { + set infoWhich__name [namespace current]::$infoWhich__name + } + regsub "^::::" $infoWhich__name "::" infoWhich__name + } + } +} +proc infoWhichYYY {} { + uplevel { + if [catch {infoWhichXXX} szErrMsg] { + verbose "infoWhichYYY error Msg: $szErrMsg" + set infoWhich__name "" + } + } +} + +namespace eval ::BlueGnu { + variable warning_threshold 0 + + variable sum_file stdout + variable all_flag 0 + + variable xfail_flag 0 + variable xfail_prms {} + # + # Print output to stdout (or stderr) and to log file + # + # If the --all flag (-a) option was used then all messages + # go the the screen. + # Without this, all messages that start with a keyword are + # written only to the + # detail log file. All messages that go to the screen will + # also appear in the + # detail log. This should only be used by the framework itself using pass, + # fail, xpass, xfail, warning, perror, note, untested, unresolved, or + # unsupported procedures. + # + proc clone_output {message} { + variable sum_file + variable all_flag + + #everything goes in the summary file + # + puts $sum_file "$message" + + # Depending on the type of message, the message is send + # to other resources + # + case [lindex [split $message] 0] in { + {"FAIL:" "XPASS:" "UNRESOLVED:" "UNSUPPORTED:" "UNTESTED:"} { + send_user "$message\n" + send_log "$message\n" + } + {"PASS:" "XFAIL:"} { + if $all_flag { + send_user "$message\n" + } + send_log "$message\n" + } + "ERROR:" { + #send_user "$message\n" + send_error "$message\n" + send_log "$message\n" + } + {"WARNING:" "NOTE:"} { + if $all_flag { + send_error "$message\n" + } + send_log "$message\n" + } + "*******" { + send_user "$message\n" + #send_log "$message\n" + #send_error "$message\n" + } + default { + send_user "$message\n" + } + } + + # we always return turn the message unchanged + # + return "$message" + } +} + +proc createTarget {args} { + verbose {In: createTarget >$args<} 3 + set szCmd "::BlueGnu::Target #auto " + set bID 0 + set bEnv 0 + set bQueue 0 + foreach item $args { + if {[string compare \ + [lindex [split $item "="] 0] szID] == 0} { + set bID 1 + } + if {[string compare \ + [lindex [split $item "="] 0] objEnvironment] == 0} { + set bEnv 1 + } + if {[string compare \ + [lindex [split $item "="] 0] objQueue] == 0} { + set bQueue 1 + } + append szCmd "\{$item\} " + } + if {! $bID} { + append szCmd "szID=Default " + } + if {! $bEnv} { + append szCmd "objEnvironment=[infoWhich \ + [::BlueGnu::Environment #auto]] " + } + if {! $bQueue} { + append szCmd "objQueue=[infoWhich [::BlueGnu::Queue #auto]] " + } + verbose {Command: >$szCmd<} 3 + set target [uplevel #0 "eval $szCmd"] + verbose {Created target: >$target<} 3 + verbose { >>>[$target <<]<<<} 4 + verbose { >>>[[infoWhich $target] <<]<<<} 4 + verbose { == [join [$target <<] "\n == "]} 3 + return [infoWhich $target] +} + +# Initialize all global variables not yet initialized +# +set szCurrentTestDirectory $env(TESTSUITEROOT) + +# Remove all temporary variables from the global space +catch {eval unset [info globals __*]} +debug {Global variables available:\ + \n [join [lsort [info globals]] "\n "]} 9 +debug {Global procedures available:\ + \n [join [lsort [info procs]] "\n "]} 9 + +foreach dir [split $env(TESTSETS) ":"] { + if {[string compare $dir $PWD] == 0} { + foreach indexFile [locateFile tclIndex] { + set indexDir [file dirname $indexFile] + if {[lsearch -exact [split $auto_path] $indexDir] < 0} { + set auto_path "$indexDir $auto_path" + } + } + foreach indexFile [locateFile tclIndex lib] { + set indexDir [file dirname $indexFile] + if {[lsearch -exact [split $auto_path] $indexDir] < 0} { + set auto_path "$indexDir $auto_path" + } + } + } else { + if {[file exists $dir/tclIndex]} { + set auto_path "$dir $auto_path" + } + } +} +debug {auto_path has been intialize to:\n [join $auto_path "\n "]} 3 +verbose {TESTSETS: >$env(TESTSETS)<} 3 diff --git a/contrib/bluegnu2.0.3/lib/testSessionUtils.itcl b/contrib/bluegnu2.0.3/lib/testSessionUtils.itcl new file mode 100644 index 0000000..4c960c4 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/testSessionUtils.itcl @@ -0,0 +1,26 @@ +# +# Procedures and other definitions for application: +# +# testSession +# + + + +proc popQueue {args} { + global szDefaultQueue + + if {[llength $args] == 1} { + set Queue [lindex $args 0] + if {[string compare [infoWhich $Queue] ""] == 0} { + error "NOT a queue >$args<" + } else { + eval [concat [infoWhich $Queue] pop] + } + } else { + if {[info exist szDefaultQueue]} { + eval [concat $szDefaultQueue pop] + } else { + error "NO default queue" + } + } +} diff --git a/contrib/bluegnu2.0.3/lib/udi.exp b/contrib/bluegnu2.0.3/lib/udi.exp new file mode 100644 index 0000000..b8c940e --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/udi.exp @@ -0,0 +1,213 @@ +# 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) + +# +# set target variables only if needed. +# +global targetname +global connectmode +global env + +if ![info exists targetname] { + if [info exists env(TARGETNAME)] { + set targetname $env(TARGETNAME) + } else { + puts stderr "ERROR: Need a target name for the udi target." + puts stderr " Use the --name option\n" + exit 1 + } +} + +# the default connect program to use +if ![info exists connectmode] { + set connectmode "mondfe" + warning "Using default of $connectmode for target communication." + if {[which mondfe] == 0} { + perror "\"mondfe\" does not exist. Check your path." + exit 1 + } +} + +# +# Connect to udi using mondfe +# +# HOSTNAME can be `iss' to talk to the simulator. +# The result is the value of `spawn_id' or -1 for failure. +# +proc mondfe { hostname } { + global shell_prompt + global spawn_id + + set retries 0 + set result -1 + + verbose "Attempting to connect to $hostname via mondfe." + spawn mondfe -D -TIP $hostname + + expect { + "$shell_prompt" { + verbose "Got prompt" + set result 0 + } + "*server bind*failed: Address already in use*" { + warning "Socket file already exists." + incr retries + if { $retries <= 2 } { + continue -expect + } + } + -indices -re ".*(UDIERROR\[^\r\n\]*)\[\r\n\]" { + warning "$expect_out(1,string)" + continue -expect + } + -indices -re ".*(DFEERROR\[^\r\n\]*)\[\r\n\]" { + warning "$expect_out(1,string)" + continue -expect + } + timeout { + warning "Timed out trying to connect." + set result -1 + incr retries + if { $retries <= 2 } { + send -i $spawn_id "\n" + continue -expect + } + } + } + + if { $result < 0 } { + perror "Couldn't connect after $retries retries." + return -1 + } else { + return $spawn_id + } +} + +# +# Downloads using the y (yank) command in mondfe +# +# SHELL_ID is the from the result of `mondfe'. +# ARG is a full path name to the file to download. +# Returns 1 if an error occured, 0 otherwise. +# +proc mondfe_download { shell_id arg } { + global decimal ;# ??? What is this? + global shell_prompt + + if ![file exists $arg] { + perror "$arg doesn't exist." + return 1 + } + + verbose "Downloading $arg." 2 + set result 1 + send -i $shell_id "y $arg\n" + expect { + -i $shell_id "y $arg*loading $arg*" { + continue -expect + } + -i $shell_id -re "Loading *TEXT section from\[^\r\]*\r" { + verbose -n "." 2 + continue -expect + } + -i $shell_id -re "Loaded *TEXT section from\[^\n\]*\n" { + verbose " TEXT section loaded." 2 + continue -expect + } + -i $shell_id -re "Loading *LIT section from\[^\r\]*\r" { + verbose -n "." 2 + continue -expect + } + -i $shell_id -re "Loaded *LIT section from\[^\n\]*\n" { + verbose " LIT section loaded." 2 + continue -expect + } + -i $shell_id -re "Loading *DATA section from\[^\r\]*\r" { + verbose -n "." 2 + continue -expect + } + -i $shell_id -re "Loaded *DATA section from\[^\n\]*\n" { + verbose " DATA section loaded." 2 + continue -expect + } + -i $shell_id -re "Clearing *BSS section from\[^\r\]*\r" { + verbose -n "." 2 + continue -expect + } + -i $shell_id -re ".*Cleared *BSS section from.*$shell_prompt$" { + verbose " BSS section cleared." 2 + verbose "Downloaded $arg successfully." 2 + set result 0 + } + -i $shell_id -re "DFEWARNING: $decimal : EMMAGIC: Bad COFF file magic number.*Command failed.*$shell_prompt$" { + warning "Bad COFF file magic number" + set result 1 + } + -i $shell_id -re ".*Ignoring COMMENT section \($decimal bytes\).*$shell_prompt$" { + verbose "Ignoring COMMENT section" 2 + verbose "Downloaded $arg successfully." 2 + set result 0 + } + -i $shell_id timeout { + perror "Timed out trying to download $arg." + set result 1 + } + } + +# FIXME: the following keeps the download from working +# "Could not read COFF section" { +# perror "Couldn't read COFF section." +# set result 1 +# } + + if { $result && [info exists expect_out(buffer)] } { + send_log $expect_out(buffer) + } + return $result +} + +# +# Exit the remote shell +# +proc exit_mondfe { shell_id } { + send -i $shell_id "q\n" + expect { + -i $shell_id "Goodbye." { + verbose "Exited mondfe $shell_id" + } + timeout { + warning "mondfe didn't exit cleanly" + } + } + + catch "close -i $shell_id" + return 0 +} + +# +# Exit the remote shell +# +proc exit_montip { shell_id } { + verbose "exiting montip $shell_id" + + catch "close -i $shell_id" + return 0 +} diff --git a/contrib/bluegnu2.0.3/lib/util-defs.exp b/contrib/bluegnu2.0.3/lib/util-defs.exp new file mode 100644 index 0000000..17fcf1a --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/util-defs.exp @@ -0,0 +1,110 @@ +# 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) + +# +# Run a utility and test the result. +# +# Parameters: +# First one is the command +# Second one is command arguments +# Third one is the file name +# Fourth one is the regexp style pattern to match for a PASS +# +# Returns: +# 1 if the test failed, +# 0 if the test passes, +# -1 if there was an internal error. +# + +proc util_test { args } { + global verbose + # get the parameters + set cmd [lindex $args 0] + verbose "Utility to execute is $cmd" 2 + set cmd_arg [lindex $args 1] + verbose "Command line arguments are $cmd_arg" 2 + set file [lindex $args 2] + verbose "The file name to use is $file" 2 + set pattern [lindex $args 3] + verbose "The pattern to match is \"$pattern\"" 2 + + if [info exists file] { + if ![string match "" $file] { + if ![file exists $file] { + perror "$file doesn't exist" + return -1 + } + } + } + + # Run the utility to be tested and analyze the results. + + set comp_output [util_start $cmd $cmd_arg $file] + + verbose "Output is \"$comp_output\"" 2 + verbose "Pattern is \"$pattern\"" 2 + + if [regexp "$pattern" $comp_output] { + verbose "Pattern matches." 2 + return 0 + } + + verbose "Pattern does not match." 2 + return 1 +} + +# +# Run the utility +# +# Return NULL or the output. +# + +proc util_start { args } { + global verbose + set cmd [lindex $args 0] + set cmd_arg [lindex $args 1] + set file [lindex $args 2] + + if {[which $cmd] == 0} { + perror "Can't find $cmd" + return "" + } + + if { $verbose > 0 } { + verbose "Spawning \"$cmd $cmd_arg $file\"" + } else { + send_log "Spawning \"$cmd $cmd_arg $file\"\n" + } + catch "exec $cmd $cmd_arg $file" comp_output + if ![string match "" $comp_output] { + send_log "$comp_output\n" + } + return $comp_output +} + +# +# add some basic error trapping. These mostly catch programming error's +# within the tests themselves +# +expect_before { + buffer_full { perror "Internal buffer is full" } + "can't open 'nmtest'" { perror "Can't open test file" } +} diff --git a/contrib/bluegnu2.0.3/lib/utils.exp b/contrib/bluegnu2.0.3/lib/utils.exp new file mode 100644 index 0000000..2372264 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/utils.exp @@ -0,0 +1,454 @@ +# 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) + +# +# Most of the procedures found here mimic their unix counter-part. +# This file is sourced by runtest.exp, so they are usable by any test case. +# + +# +# Gets the directories in a directory +# args: the first is the dir to look in, the next +# is the pattern to match. It +# defaults to *. Patterns are csh style +# globbing rules +# returns: a list of dirs or NULL +# +proc getdirs { args } { + set path [lindex $args 0] + if { [llength $args] > 1} { + set pattern [lindex $args 1] + } else { + set pattern "*" + } + verbose "Looking in ${path} for directories that match \"${pattern}\"" 3 + catch "glob ${path}/${pattern}" tmp + if { ${tmp} != "" } { + foreach i ${tmp} { + if [file isdirectory $i] { + switch -- "[file tail $i]" { + "testsuite" - + "config" - + "lib" - + "CVS" - + "RCS" - + "SCCS" { + verbose "Ignoring directory [file tail $i]" 3 + continue + } + default { + if [file readable $i] { + verbose "Found directory [file tail $i]" 3 + lappend dirs $i + } + } + } + } + } + } else { + perror "$tmp" + return "" + } + + if ![info exists dirs] { + return "" + } else { + return $dirs + } +} + +# +# Finds all the files recursively +# rootdir - this is the directory to start the search +# from. This is and all subdirectories are search for +# filenames. Directory names are not included in the +# list, but the filenames have path information. +# pattern - this is the pattern to match. Patterns are csh style +# globbing rules. +# returns: a list or a NULL. +# +proc find { rootdir pattern } { + # first find all the directories + set dirs "$rootdir " + while 1 { + set tmp $rootdir + set rootdir "" + if [string match "" $tmp] { + break + } + foreach i $tmp { + set j [getdirs $i] + if ![string match "" $j] { + append dirs "$j " + set rootdir $j + unset j + } else { + set rootdir "" + } + } + set tmp "" + } + + # find all the files that match the pattern + foreach i $dirs { + verbose "Looking in $i" 3 + set tmp [glob -nocomplain $i/$pattern] + if { [llength $tmp] != 0 } { + foreach j $tmp { + if ![file isdirectory $j] { + lappend files $j + verbose "Adding $j to file list" 3 + } + } + } + } + + if ![info exists files] { + lappend files "" + } + return $files +} + +# +# Search the path for a file. This is basically a version +# of the BSD-unix which utility. This procedure depends on +# the shell environment variable $PATH. It returns 0 if $PATH +# does not exist or the binary is not in the path. If the +# binary is in the path, it returns the full path to the binary. +# +proc which { file } { + global env + + # strip off any extraneous arguments (like flags to the compiler) + set file [lindex $file 0] + + # if it exists then the path must be OK + # ??? What if $file has no path and "." isn't in $PATH? + if [file exists $file] { + return $file + } + if [info exists env(PATH)] { + set path [split $env(PATH) ":"] + } else { + return 0 + } + + foreach i $path { + verbose "Checking against $i" 3 + if [file exists $i/$file] { + if [file executable $i/$file] { + return $i/$file + } else { + warning "$i/$file exists but is not an executable" + } + } + } + # not in path + return 0 +} + +# +# Looks for a string in a file. +# return:list of lines that matched or NULL if none match. +# args: first arg is the filename, +# second is the pattern, +# third are any options. +# Options: line - puts line numbers of match in list +# +proc grep { args } { + + set file [lindex $args 0] + set pattern [lindex $args 1] + + verbose "Grepping $file for the pattern \"$pattern\"" 3 + + set argc [llength $args] + if { $argc > 2 } { + for { set i 2 } { $i < $argc } { incr i } { + append options [lindex $args $i] + append options " " + } + } else { + set options "" + } + + set i 0 + set fd [open $file r] + while { [gets $fd cur_line]>=0 } { + incr i + if [regexp -- "$pattern" $cur_line match] { + if ![string match "" $options] { + foreach opt $options { + case $opt in { + "line" { + lappend grep_out [concat $i $match] + } + } + } + } else { + lappend grep_out $match + } + } + } + close $fd + unset fd + unset i + if ![info exists grep_out] { + set grep_out "" + } + return $grep_out +} + +# +# Remove elements based on patterns. elements are delimited by spaces. +# pattern is the pattern to look for using glob style matching +# list is the list to check against +# returns the new list +# +proc prune { list pattern } { + foreach i $list { + verbose "Checking pattern \"$pattern\" against $i" 3 + if ![string match $pattern $i] { + lappend tmp $i + } else { + verbose "Removing element $i from list" 3 + } + } + return $tmp +} + +# +# Attempt to kill a process that you started +# +proc slay { name } { + set in [open [concat "|ps"] r] + while {[gets $in line]>-1} { + if ![string match "*expect*slay*" $line] { + if [string match "*$name*" $line] { + set pid [lindex $line 0] + catch "exec kill -9 $pid]" + verbose "Killing $name, pid = $pid\n" + } + } + } + close $in +} + +# +# Convert a relative path to an absolute one +# +proc absolute { path } { + if [string match "." $path] { + return [pwd] + } + + set basedir [pwd] + cd $path + set path [pwd] + cd $basedir + return $path +} + +# +# Source a file and trap any real errors. This ignores extraneous +# output. returns a 1 if there was an error, otherwise it returns 0. +# +proc psource { file } { + global errorInfo + global errorCode + + unset errorInfo + if [file exists $file] { + catch "source $file" + if [info exists errorInfo] { + send_error "ERROR: errors in $file\n" + send_error "$errorInfo" + return 1 + } + } + return 0 +} + +# +# Check if a testcase should be run or not +# +# RUNTESTS is a copy of global `runtests'. +# +# This proc hides the details of global `runtests' from the test scripts, and +# implements uniform handling of "script arguments" where those arguments are +# file names (ie: the "foo" in make check RUNTESTFLAGS="bar.exp=foo"). +# "glob" style expressions are supported as well as multiple files (with +# spaces between them). +# Eg: RUNTESTFLAGS="bar.exp=foo1.c foo2.c foo3*.c bar*.c" +# +proc runtest_file_p { runtests testcase } { + if [string length [lindex $runtests 1]] { + set testcase [file tail $testcase] + foreach ptn [lindex $runtests 1] { + if [string match $ptn $testcase] { + return 1 + } + } + return 0 + } + return 1 +} + +# +# Delete various system verbosities from TEXT on SYSTEM +# +# An example is: +# ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9 +# +# SYSTEM is typical $target_triplet or $host_triplet. +# +# This is useful when trying to do pattern matches on program output. +# Sites with particularily verbose os's may wish to override this in site.exp. +# +# We get loaded after site.exp so only define this if not already defined. +# + +if { [info procs prune_system_crud] == "" } { + proc prune_system_crud { system 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. + regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text + + # This happens when compiling on Alpha OSF/1 with cc -g -O. + regsub -all "(^|\n)(\n*uopt: Warning: file not optimized; use -g3 if both optimization and debug wanted\n?)+" $text "\\1" text + + # This happens when compiling on Alpha OSF using gas. + regsub -all "(^|\n)(/usr/ucb/ld:\nWarning: Linking some objects which contain exception information sections\n\tand some which do not. This may cause fatal runtime exception handling\n\tproblems\[^\n\]*\n?)+" $text "\\1" text + + # This happens on SunOS with cc -g -O. + regsub -all "(^|\n)(cc: Warning: -O conflicts with -g. -O turned off.\n?)+" $text "\\1" text + + # This happens when using g++ on a DWARF system. + regsub -all "(^|\n)(cc1plus: warning: -g option not supported for C\\+\\+ on systems using the DWARF debugging format\n?)+" $text "\\1" 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 + } +} + +# +# Compares two files line-by-line +# returns 1 it the files match, +# returns 0 if there was a file error, +# returns -1 if they didn't match. +# +proc diff { file_1 file_2 } { + set eof -1 + set differences 0 + + if [file exists ${file_1}] { + set file_a [open ${file_1} r] + } else { + warning "${file_1} doesn't exist" + return 0 + } + + if [file exists ${file_2}] { + set file_b [open ${file_2} r] + } else { + warning "${file_2} doesn't exist" + return 0 + } + + verbose "# Diff'ing: ${file_1} ${file_2}\n" 1 + + while { [gets ${file_a} line] != ${eof} } { + if [regexp "^#.*$" ${line}] { + continue + } else { + lappend list_a ${line} + } + } + close ${file_a} + + while { [gets ${file_b} line] != ${eof} } { + if [regexp "^#.*$" ${line}] { + continue + } else { + lappend list_b ${line} + } + } + close ${file_b} + for { set i 0 } { $i < [llength $list_a] } { incr i } { + set line_a [lindex ${list_a} ${i}] + set line_b [lindex ${list_b} ${i}] + +# verbose "\t${file_1}: ${i}: ${line_a}\n" 3 +# verbose "\t${file_2}: ${i}: ${line_b}\n" 3 + if [string compare ${line_a} ${line_b}] { + verbose "line #${i}\n" 2 + verbose "\< ${line_a}\n" 2 + verbose "\> ${line_b}\n" 2 + + send_log "line #${i}\n" + send_log "\< ${line_a}\n" + send_log "\> ${line_b}\n" + + set differences -1 + } + } + + if { [llength ${list_a}] != [llength ${list_b}] } { + verbose "Files not the same" 2 + set differences -1 + } else { + verbose "Files are the same" 2 + set differences 1 + } + return ${differences} +} + +# +# Set an environment variable +# +proc setenv { var val } { + global env + + set env($var) $val +} + +# +# Unset an environment variable +# +proc unsetenv { var } { + global env + unset env($var) +} + +# +# Get a value from an environment variable +# +proc getenv { var } { + global env + + if [info exists env($var)] { + return $env($var) + } else { + return "" + } +} + diff --git a/contrib/bluegnu2.0.3/lib/vrtx.exp b/contrib/bluegnu2.0.3/lib/vrtx.exp new file mode 100644 index 0000000..91be6c5 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/vrtx.exp @@ -0,0 +1,334 @@ +# 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: The usage of `shell_id' as a global here seems wrong. Most targets +# have it local to the file of our caller. See for example udi.exp. +set shell_id 0 + +# +# set default values +# + +global env +if ![info exists env(SPECTRA)] { + perror "SPECTRA environment variable is not set." + exit 1 +} else { + set SPECTRA $env(SPECTRA) + append CFLAGS " -I $SPECTRA/target/include" +} + +# the hostname of the target board + +global targetname +if ![info exists targetname] { + puts stderr "ERROR: Need a target name for Spectra." + puts stderr " Use the --target option\n" + exit 1 +} + +# the default connect program to use +global connectmode +if ![info exists connectmode] { + set connectmode "xsh" + warning "Using default of $connectmode for target communication." +} + +# +# Connect to Spectra (VTRX) using xsh +# +proc xsh { hostname } { + global verbose + global hex + global connectmode + global shell_prompt + global spawn_id + global shell_id + global spawn_id + global env + global target_triplet + + set retries 0 + set result 0 + if {[which xsh] != 0} { + spawn xsh + } else { + warning "Can't find xsh in path" + return + } + + set shell_id $spawn_id + + # start the shell + expect { + "*Spectra Cross-Development Shell version*$shell_prompt" { + verbose "Got prompt" + set result 0 + } + timeout { + warning "Timed out trying to connect." + set result -1 + incr retries + if { $retries <= 2 } { + exp_continue + } + } + } + + # connect to the shell + set retries 0 + send "connect $hostname\n" + expect { + "connect $hostname*$hostname connected \(non-os mode\)*\n" { + set shell_prompt "$hostname> " + verbose "Connected to $hostname" + } + "*connect: not attached*" { + warning "Couldn't attach target" + set result -1 + } + -re ".* reset on target.*$" { + send_user "Spectra was reset\n" + exp_continue + } + -re "\[0-9A-Fa-f\]+\[ 0x\]+\[0-9A-Fa-f\]+.*$" { + exp_continue + } + "$hostname> " { + #send "\n" + } + timeout { + warning "Timed out trying to connect after $expect_out(seconds) seconds." + set result -1 + incr retries + if { $retries <= 2 } { + exp_continue + } + } + } + + send "\n\n\n" + expect { + "*$hostname*$hostname" { + verbose "Cleared reset messages" 1 + } + timeout { + warning "Couldn't clear reset messages" + set result 1 + } + } + + # load to operating system + set timeout 20 + set retries 0 + if {[xsh_load $env(SPECTRA)/${target_triplet}-os.o {-e sys_start_crt0}]!=0} { + perror "Couldn't load Spectra into target" + return -1 + } + + set timeout 10 + # start the OS running + set retries 0 + send "go\n" + expect { + -re ".*Multithreading on target darkstar.*$" { + verbose "Spectra has been started..." 1 + set result 0 + } + -re ".*reset on target.*$" { + verbose "Spectra was reset" + exp_continue + } + -re "\[0-9A-Fa-f\]+\[ 0x\]+\[0-9A-Fa-f\]+.*$" { + #send "\n" + exp_continue + } + -re "go\n" { exp_continue } + "$shell_prompt" { exp_continue } + timeout { + perror "Spectra wouldn't start" + set result -1 + incr retries + if { $retries <= 2 } { + send "go\r" + exp_continue + } + } + } + + if { $result < 0 } { + perror "Couldn't connect after $retries retries.\n" + return -1 + } else { + return $spawn_id + } +} + +# +# Downloads using the load command in Spectra +# arg - is a full path name to the file to download +# returns 1 if a spectra error occured, +# -1 if an internal error occured, +# 0 otherwise. +# +proc xsh_load { args } { + global verbose + global shell_id + global decimal + global hex + global shell_prompt + global expect_out + + set result 1 + set retries 0 + + if { [llength $args] == 1 } { + set opts "" + } else { + set opts [lindex $args 1] + } + set file [lindex $args 0] + + if ![file exists $file] { + perror "$file doesn't exist." + return 1 + } + + verbose "Downloading $file..." + + send -i $shell_id "load $opts $file\r" + set force 0 + expect { + -i $shell_id -re "\[0-9A-Fa-f\]+\[ 0x\]+\[0-9A-Fa-f\]+\r\n" { + set timeout 1 + send "dout\n" + while $force<2 { + expect { + "dout*undefined kernel symbol*$shell_prompt" { + verbose "Attempted to flush I/O buffers" 1 + } + timout { + incr force + flush stdout + } + } + } + set timeout 20 + exp_continue + } + -i $shell_id "load $opts $file*\r" { + verbose "Loading a.out..." + exp_continue + } + -i $shell_id "Warm reset on target*\n" { + verbose "Spectra did a warm reset" + exp_continue + } + -i $shell_id "Cold reset on target*\n" { + verbose "Spectra did a cold reset" + exp_continue + } + -i $shell_id "loading a.out*\r" { + verbose "Loading a.out..." + exp_continue + } + -i $shell_id "reading symbols*\r" { + verbose "Reading symbols..." + exp_continue + } + -i $shell_id "defining symbols*\r" { + verbose "defining symbols..." + exp_continue + } + -i $shell_id "*loading image*\r" { + verbose "Loading image..." + exp_continue + } + -i $shell_id -re ".*bytes loaded:.*$decimal.*$" { + verbose "$expect_out(buffer)" + exp_continue + } + -i $shell_id "*loading done*\r" { + verbose "Loading done..." + exp_continue + } + -i $shell_id "*setting PC*\r" { + verbose "Setting PC..." + exp_continue + } + -i $shell_id "*resolving symbols*\r" { + verbose "Resolving symbols..." + exp_continue + } + -i $shell_id -re ".*load module id = $decimal.*$" { + verbose "" + } + } + -i $shell_id -re ".*load: undefined symbols.*$" { + perror "undefined symbols, make sure os is loaded and running" + set result -1 + } + -i $shell_id "$shell_prompt" { + set result 0 + exp_continue + } + -i $shell_id "load: no default target" { + perror "default target isn't set" + return -1 + } + -i $shell_id timeout { + perror "Timed out trying to download after $expect_out(seconds) seconds." + incr retries + set result 1 + if { $retries <= 2 } { + exp_continue + } + } + } + + set timeout 10 + if [info exists expect_out(buffer)] { + send_log $expect_out(buffer) + } + return $result +} + +# +# Exit the remote shell +# +proc xsh_exit { shell_id } { + global verbose + global connectmode + global targetname + global shell_prompt + global shell_id + + send -i $shell_id "exit\n" + + verbose "Exiting shell." + set shell_id 0 + return 0 +} + + + + diff --git a/contrib/bluegnu2.0.3/lib/vxworks.exp b/contrib/bluegnu2.0.3/lib/vxworks.exp new file mode 100644 index 0000000..cf7c3bd --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/vxworks.exp @@ -0,0 +1,265 @@ +# 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) + +# +# set target variables only if needed. +# +global targetname +global connectmode +global env +global checktask + +if ![info exists targetname] { + if [info exists env(TARGETNAME)] { + set targetname $env(TARGETNAME) + } else { + puts stderr "ERROR: Need a target name for the vxworks board." + puts stderr " Use the --name option\n" + exit 1 + } +} + +# The default connect program to use. +if ![info exists connectmode] { + set connectmode "telnet" + warning "Using default of $connectmode for target communication." +} + +if ![info exists checktask] { + set checktask "fp" +} + +# +# Compute a path to vxworks' value for it +# +# We use a default ftp device called "filesys" to load files from. +# This way it works without NFS. +# This proc may be overridden by the user. The typical thing to do is use +# a different name for the device, but it might also return a different path +# to PROG. +# +# ??? This is experimental. This kind of thing can't be specified on the +# command line, but neither can specifying the kinds of transformations that +# one might want to do without actually passing tcl code at which point it +# makes just as much sense to stick it in a config file. +# +if { [info procs vxworks_transform_path] == "" } { + proc vxworks_transform_path { prog } { + return "filesys:$prog" + } +} + +# +# Load a file into vxworks +# +# The result is: +# 0 - success +# 1 - failed (eg: link failed so testcase should fail) +# -1 - unresolved (eg: timeout, bad passwd) +# -2 - unsupported (not used) +# -3 - untested (not used) +# +proc vxworks_ld { shell_id prog } { + global shell_prompt + global expect_out + global logname + global passwd + global decimal hex + + set timeout 100 ;# for this call only + set result -7 ;# -7 is a local value meaning "not done" + set tries 0 + set maxtries 3 + + set prog [vxworks_transform_path $prog] + + if { $passwd != "" } { + send -i $shell_id "iam \"$logname\",\"$passwd\"\r" + } else { + send -i $shell_id "iam \"$logname\"\r" + } + expect { + -i $shell_id "iam*value = 0 = 0x0*$shell_prompt" { + verbose "Set default user." 2 + } + -i $shell_id timeout { + # ??? This is really an error. It's not clear whether `perror' + # or `warning' should be used here. There are *lots* of other + # cases like this. + perror "Couldn't set default user." + set result -1 + } + } + + # We always want to exit the program via the code at the end. + # If the load fails we want `expect_out' stored in the log and this + # saves duplicating that code. + + while { $result == -7 } { + verbose "Loading $prog into vxworks." + send -i $shell_id "ld < $prog\r" + incr tries + expect { + -i $shell_id "Login incorrect." { + if { $tries == $maxtries } { + perror "Login failed." + set result -1 + break + } + if [string match "" $passwd] { + stty -echo + warning "Login failed for default user" + send_user "Type in password (for $logname) please: " + expect_user -re "(.*)\n" + send_user "\n" + set passwd "$expect_out(1,string)" + stty echo + } + send -i $shell_id "iam \"$logname\",\"$passwd\"\r" + expect { + -i $shell_id "iam*value = 0 = 0x0*$shell_prompt " { + verbose "Set new user and password" 2 + } + -i $shell_id timeout { + perror "Couldn't set user and password (timed out)." + set result -1 + } + } + } + -i $shell_id -re "USER.*command not understood" { + perror "Need to set the user and password." + set result -1 + } + -i $shell_id -re "ld <.*undefined symbol:.*$shell_prompt $" { + # This is an error in the testcase, don't call perror. + warning "Undefined symbol, $prog not loaded." + set result 1 + } + -i $shell_id -re "ld <.*can't open input.*$shell_prompt $" { + perror "Can't access $prog." + set result -1 + } + -i $shell_id -re "ld <.*value = ${decimal} = ${hex}.*$shell_prompt $" { + verbose "Loaded $prog into vxworks." + set result 0 + } + -i $shell_id -re "ld <\[^\r\]*\r(.*)$shell_prompt $" { + warning "Load failed: $expect_out(1,string)" + set result -1 + } + -i $shell_id timeout { + warning "Timed out trying load $prog." + set result -1 + } + } + } + + if { $result && [info exists expect_out(buffer)] } { + send_log "$expect_out(buffer)" + } + return $result +} + +# +# Start a thread (process) executing +# +# The result is: +# 0 - success +# 1 - failed (eg: testcase aborted) +# -1 - unresolved (eg: timeout) +# -2 - unsupported (not used) +# -3 - untested (not used) +# +proc vxworks_spawn { shell_id function } { + global shell_prompt + global checktask + + # There isn't a command to wait for a thread to finish, so we have to keep + # polling. Bummer. + + set timeout 20 ;# for this call only + + send -i $shell_id "sp $function\r" + expect { + -i $shell_id -re "sp $function.*task spawned:.*name = (\[a-z0-9\]+).*value = (\[0-9\]+).*$shell_prompt $" { + set name $expect_out(1,string) + set value $expect_out(2,string) + verbose "$function running, name $name, value $value" + set tries 0 + set maxtries 100 ;# Don't hang on testcases with infinite loops. + set result -7 ;# "not done" + while { $result == -7 } { + # Get the task's frame pointer. + # VxWorks will return -1 if the task isn't running. + send -i $shell_id "$checktask \"$name\"\r" + incr tries + expect { + -i $shell_id -re "task $value - aborted.*$shell_prompt $" { + # FIXME: It's not clear we'll ever get here. + verbose "$function aborted" + set result 1 + } + -i $shell_id -re ".*AbOrT.*$shell_prompt $" { + # This requires support from the environment to + # redefine abort() to print this. + verbose "$function aborted" + set result 1 + } + # This is here to try to cope with apparently flaky h/w. + -i $shell_id -re ".*Bus Error.*$" { + # This is potentially an error in the testcase, + # don't call perror. + warning "Bus Error." + # Delete the task (it's still around). + send -i $shell_id "td $name\r" + set result 1 + } + -i $shell_id -re "value = \[0-9\]+.*$shell_prompt $" { + # Task is still running. + if { $tries == $maxtries } { + warning "$function started, won't stop" + set result -1 + } else { + catch "exec sleep 1" + } + } + -i $shell_id -re "value = -1.*$shell_prompt $" { + # Task is no longer running. + set result 0 + } + -i $shell_id timeout { + warning "$function started, can't determine status (timed out)" + set result -1 + } + } + } + } + -i $shell_id timeout { + warning "Couldn't run $function (timed out)" + set result -1 + } + } + + if { $result && [info exists expect_out(buffer)] } { + send_log "$expect_out(buffer)" + } + return $result +} |