# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
|
# 2001 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2012, 2016 Free
|
# Software Foundation, Inc.
|
#
|
# This file is part of DejaGnu.
|
#
|
# DejaGnu 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 3 of the License, or
|
# (at your option) any later version.
|
#
|
# DejaGnu 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 DejaGnu; if not, write to the Free Software Foundation,
|
# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
|
|
# 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"
|
}
|
}
|
|
# Insert DTD for xml format checking.
|
#
|
proc insertdtd { } {
|
xml_output "<!DOCTYPE testsuite \[
|
<!-- testsuite.dtd -->
|
<!ELEMENT testsuite (test | summary)+>
|
<!ELEMENT test (input, output, result, name, prms_id )>
|
<!ELEMENT input (#PCDATA)>
|
<!ELEMENT output (#PCDATA)>
|
<!ELEMENT result (#PCDATA)>
|
<!ELEMENT name (#PCDATA)>
|
<!ELEMENT prms_id (#PCDATA)>
|
<!ELEMENT summary (result, description, total)>
|
<!ELEMENT description (#PCDATA)>
|
<!ELEMENT total (#PCDATA)>
|
\]>"
|
}
|
|
# Open the output logs.
|
#
|
proc open_logs { } {
|
global outdir
|
global tool
|
global sum_file
|
global xml_file
|
global xml_file_name
|
global xml
|
|
if { ${tool} == "" } {
|
set tool testrun
|
}
|
catch "file delete -force -- $outdir/$tool.sum"
|
set sum_file [open [file join $outdir $tool.sum] w]
|
if { $xml } {
|
catch "file delete -force -- $outdir/$tool.xml"
|
if { ![string compare $xml_file_name ""] } {
|
set xml_file_name $tool.xml
|
}
|
set xml_file [open [file join $outdir $xml_file_name] w]
|
xml_output "<?xml version=\"1.0\"?>"
|
insertdtd
|
xml_output "<testsuite>"
|
}
|
catch "file delete -force -- $outdir/$tool.log"
|
log_file -a "$outdir/$tool.log"
|
verbose "Opening log files in $outdir"
|
if { ${tool} == "testrun" } {
|
set tool ""
|
}
|
fconfigure $sum_file -buffering line
|
}
|
|
# Close the output logs.
|
#
|
proc close_logs { } {
|
global sum_file
|
global xml
|
global xml_file
|
|
if { $xml } {
|
xml_output "</testsuite>"
|
catch "close $xml_file"
|
}
|
|
catch "close $sum_file"
|
}
|
|
# Check build host triplet for PATTERN.
|
# With no arguments it returns the triplet string.
|
#
|
proc isbuild { pattern } {
|
global build_triplet
|
global host_triplet
|
|
if {![info exists build_triplet]} {
|
set build_triplet ${host_triplet}
|
}
|
if {[string match "" $pattern]} {
|
return $build_triplet
|
}
|
verbose "Checking pattern \"$pattern\" with $build_triplet" 2
|
|
if {[string match "$pattern" $build_triplet]} {
|
return 1
|
} else {
|
return 0
|
}
|
}
|
|
# Is $board remote? Return a non-zero value if so.
|
#
|
proc is_remote { board } {
|
global host_board
|
global target_list
|
|
verbose "calling is_remote $board" 3
|
# Remove any target variant specifications from the name.
|
set board [lindex [split $board "/"] 0]
|
|
# Map the host or build back into their short form.
|
if { [board_info build name] == $board } {
|
set board "build"
|
} elseif { [board_info host name] == $board } {
|
set board "host"
|
}
|
|
# We're on the "build". The check for the empty string is just for
|
# paranoia's sake--we shouldn't ever get one. "unix" is a magic
|
# string that should really go away someday.
|
if { $board == "build" || $board == "unix" || $board == "" } {
|
verbose "board is $board, not remote" 3
|
return 0
|
}
|
|
if { $board == "host" } {
|
if { [info exists host_board] && $host_board != "" } {
|
verbose "board is $board, is remote" 3
|
return 1
|
} else {
|
verbose "board is $board, host is local" 3
|
return 0
|
}
|
}
|
|
if { $board == "target" } {
|
global current_target_name
|
|
if {[info exists current_target_name]} {
|
# This shouldn't happen, but we'll be paranoid anyway.
|
if { $current_target_name != "target" } {
|
return [is_remote $current_target_name]
|
}
|
}
|
return 0
|
}
|
if {[board_info $board exists isremote]} {
|
verbose "board is $board, isremote is [board_info $board isremote]" 3
|
return [board_info $board isremote]
|
}
|
return 1
|
}
|
|
# 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 { pattern } {
|
global host_triplet
|
|
if {[string match "" $pattern]} {
|
return $host_triplet
|
}
|
verbose "Checking pattern \"$pattern\" with $host_triplet" 2
|
|
if {[string match "$pattern" $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."
|
}
|
}
|
|
set triplet [lindex $args 0]
|
|
# now check against the cannonical name
|
if {[info exists target_triplet]} {
|
verbose "Checking \"$triplet\" against \"$target_triplet\"" 2
|
if {[string match $triplet $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
|
#
|
# Rename unknown to tcl_unknown so that we can wrap tcl_unknown.
|
# This allows Tcl package autoloading to work in the modern age.
|
|
rename ::unknown ::tcl_unknown
|
proc unknown args {
|
if {[catch {uplevel 1 ::tcl_unknown $args} msg]} {
|
global errorCode
|
global errorInfo
|
global exit_status
|
|
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"
|
}
|
set exit_status 2
|
log_and_exit
|
}
|
}
|
|
# 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, kpass, kfail, warning, perror, note, untested, unresolved,
|
# or unsupported procedures.
|
#
|
proc clone_output { message } {
|
global sum_file
|
global all_flag
|
|
if { $sum_file != "" } {
|
puts $sum_file "$message"
|
}
|
|
regsub "^\[ \t\]*(\[^ \t\]+).*$" "$message" "\\1" firstword
|
switch -glob -- "$firstword" {
|
"PASS:" -
|
"XFAIL:" -
|
"KFAIL:" -
|
"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 a few counters.
|
#
|
proc reset_vars {} {
|
global test_names test_counts
|
global warncnt errcnt
|
|
# other miscellaneous variables
|
global prms_id
|
global bug_id
|
|
# reset them all
|
set prms_id 0
|
set bug_id 0
|
set warncnt 0
|
set errcnt 0
|
foreach x $test_names {
|
set test_counts($x,count) 0
|
}
|
|
# Variables local to this file.
|
global warning_threshold perror_threshold
|
set warning_threshold 3
|
set perror_threshold 1
|
}
|
|
proc log_and_exit {} {
|
global exit_status
|
global tool mail_logs outdir mailing_list
|
|
log_summary total
|
# extract version number
|
if {[info procs ${tool}_version] != ""} {
|
if {[catch "${tool}_version" output]} {
|
warning "${tool}_version failed:\n$output"
|
}
|
}
|
close_logs
|
verbose -log "runtest completed at [timestamp -format %c]"
|
if {$mail_logs} {
|
if { ${tool} == "" } {
|
set tool testrun
|
}
|
mail_file $outdir/$tool.sum $mailing_list "Dejagnu Summary Log"
|
}
|
remote_close host
|
remote_close target
|
exit $exit_status
|
}
|
|
proc xml_output { message } {
|
global xml_file
|
if { $xml_file != "" } {
|
puts $xml_file "$message"
|
}
|
}
|
|
# Print summary of all pass/fail counts.
|
#
|
proc log_summary { args } {
|
global tool
|
global sum_file
|
global xml_file
|
global xml
|
global exit_status
|
global mail_logs
|
global outdir
|
global mailing_list
|
global current_target_name
|
global test_counts
|
global testcnt
|
|
if { [llength $args] == 0 } {
|
set which "count"
|
} else {
|
set which [lindex $args 0]
|
}
|
|
if { [llength $args] == 0 } {
|
clone_output "\n\t\t=== $tool Summary for $current_target_name ===\n"
|
} else {
|
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 {[info exists testcnt]} {
|
if { $testcnt > 0 } {
|
set totlcnt 0
|
# total all the testcases reported
|
foreach x { FAIL PASS XFAIL KFAIL XPASS KPASS UNTESTED UNRESOLVED UNSUPPORTED } {
|
incr totlcnt test_counts($x,$which)
|
}
|
set testcnt test_counts(total,$which)
|
|
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"
|
}
|
}
|
}
|
foreach x { PASS FAIL XPASS XFAIL KPASS KFAIL UNRESOLVED UNTESTED UNSUPPORTED } {
|
set val $test_counts($x,$which)
|
if { $val > 0 } {
|
set mess "# of $test_counts($x,name)"
|
if { $xml } {
|
xml_output " <summary>"
|
xml_output " <result>$x</result>"
|
xml_output " <description>$mess</description>"
|
xml_output " <total>$val</total>"
|
xml_output " </summary>"
|
}
|
if { [string length $mess] < 24 } {
|
append mess "\t"
|
}
|
clone_output "$mess\t$val"
|
}
|
}
|
}
|
|
# 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 bug report ID can be specified,
|
# which is a string without '-'.
|
#
|
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 string with no '-' characters
|
if {[regexp "^\[^\-\]+$" $sub_arg]} {
|
set xfail_prms $sub_arg
|
continue
|
}
|
if {[istarget $sub_arg]} {
|
set xfail_flag 1
|
continue
|
}
|
}
|
}
|
|
# Setup a flag to control whether it is a known failure.
|
#
|
# A bug report ID _MUST_ be specified, and is the first argument.
|
# It still must be a string without '-' so we can be sure someone
|
# did not just forget it and we end-up using a target triple as
|
# bug id.
|
#
|
# Multiple target triplet patterns can be specified for targets
|
# for which the test is known to fail.
|
#
|
proc setup_kfail { args } {
|
global kfail_flag
|
global kfail_prms
|
|
set kfail_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 string with no '-' characters
|
if {[regexp "^\[^\-\]+$" $sub_arg]} {
|
set kfail_prms $sub_arg
|
continue
|
}
|
if {[istarget $sub_arg]} {
|
set kfail_flag 1
|
continue
|
}
|
}
|
|
if {$kfail_prms == 0} {
|
perror "Attempt to set a kfail without specifying bug tracking id"
|
}
|
}
|
|
# Check to see if a conditional xfail is triggered.
|
# message {targets} {include} {exclude}
|
#
|
proc check_conditional_xfail { args } {
|
global compiler_flags
|
|
set all_args [lindex $args 0]
|
|
set message [lindex $all_args 0]
|
|
set target_list [lindex $all_args 1]
|
verbose "Limited to targets: $target_list" 3
|
|
# get the list of flags to look for
|
set includes [lindex $all_args 2]
|
verbose "Will search for options $includes" 3
|
|
# get the list of flags to exclude
|
if { [llength $all_args] > 3 } {
|
set excludes [lindex $all_args 3]
|
verbose "Will exclude for options $excludes" 3
|
} else {
|
set excludes ""
|
}
|
|
# loop through all the targets, checking the options for each one
|
verbose "Compiler flags are: $compiler_flags" 2
|
|
set incl_hit 0
|
set excl_hit 0
|
foreach targ $target_list {
|
if {[istarget $targ]} {
|
# look through the compiler options for flags we want to see
|
# this is really messy cause each set of options to look for
|
# may also be a list. We also want to find each element of the
|
# list, regardless of order to make sure they're found.
|
# So we look for lists in side of lists, and make sure all
|
# the elements match before we decide this is legit.
|
# Se we 'incl_hit' to 1 before the loop so that if the 'includes'
|
# list is empty, this test will report a hit. (This can be
|
# useful if a target will always fail unless certain flags,
|
# specified in the 'excludes' list, are used.)
|
set incl_hit 1
|
for { set i 0 } { $i < [llength $includes] } { incr i } {
|
set incl_hit 0
|
set opt [lindex $includes $i]
|
verbose "Looking for $opt to include in the compiler flags" 2
|
foreach j "$opt" {
|
if {[string match "* $j *" $compiler_flags]} {
|
verbose "Found $j to include in the compiler flags" 2
|
incr incl_hit
|
}
|
}
|
# if the number of hits we get is the same as the number of
|
# specified options, then we got a match
|
if {$incl_hit == [llength $opt]} {
|
break
|
} else {
|
set incl_hit 0
|
}
|
}
|
# look through the compiler options for flags we don't
|
# want to see
|
for { set i 0 } { $i < [llength $excludes] } { incr i } {
|
set excl_hit 0
|
set opt [lindex $excludes $i]
|
verbose "Looking for $opt to exclude in the compiler flags" 2
|
foreach j "$opt" {
|
if {[string match "* $j *" $compiler_flags]} {
|
verbose "Found $j to exclude in the compiler flags" 2
|
incr excl_hit
|
}
|
}
|
# if the number of hits we get is the same as the number of
|
# specified options, then we got a match
|
if {$excl_hit == [llength $opt]} {
|
break
|
} else {
|
set excl_hit 0
|
}
|
}
|
|
# if we got a match for what to include, but didn't find any reasons
|
# to exclude this, then we got a match! So return one to turn this into
|
# an expected failure.
|
if {$incl_hit && ! $excl_hit } {
|
verbose "This is a conditional match" 2
|
return 1
|
} else {
|
verbose "This is not a conditional match" 2
|
return 0
|
}
|
}
|
}
|
return 0
|
}
|
|
# 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 ]
|
switch -glob -- $sub_arg {
|
"*-*-*" { # is a configuration triplet
|
if {[istarget $sub_arg]} {
|
set xfail_flag 0
|
set xfail_prms 0
|
}
|
continue
|
}
|
}
|
}
|
}
|
|
# Clear the kfail flag for a particular target.
|
#
|
proc clear_kfail { args } {
|
global kfail_flag
|
global kfail_prms
|
|
set argc [ llength $args ]
|
for { set i 0 } { $i < $argc } { incr i } {
|
set sub_arg [ lindex $args $i ]
|
switch -glob -- $sub_arg {
|
"*-*-*" { # is a configuration triplet
|
if {[istarget $sub_arg]} {
|
set kfail_flag 0
|
set kfail_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 args } {
|
global exit_status
|
global xml
|
global prms_id bug_id
|
global xfail_flag xfail_prms
|
global kfail_flag kfail_prms
|
global errcnt warncnt
|
global warning_threshold perror_threshold
|
global pf_prefix
|
|
if { [llength $args] > 0 } {
|
set count [lindex $args 0]
|
} else {
|
set count 1
|
}
|
if {[info exists pf_prefix]} {
|
set message [concat $pf_prefix " " $message]
|
}
|
|
# 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 } {
|
verbose "Error/Warning threshold exceeded: \
|
$errcnt $warncnt (max. $perror_threshold $warning_threshold)"
|
set type UNRESOLVED
|
}
|
|
incr_count $type
|
|
if { $xml } {
|
global errorInfo
|
set error ""
|
if {[info exists errorInfo]} {
|
set error $errorInfo
|
}
|
global expect_out
|
set rio { "" "" }
|
if { [catch { set rio [split $expect_out(buffer) "\n"] } result]} {
|
#do nothing - leave as { "" "" }
|
}
|
|
set output ""
|
set output "expect_out(buffer)"
|
xml_output " <test>"
|
xml_output " <input>[string trimright [lindex $rio 0]]</input>"
|
xml_output " <output>[string trimright [lindex $rio 1]]</output>"
|
xml_output " <result>$type</result>"
|
xml_output " <name>$message</name>"
|
xml_output " <prms_id>$prms_id</prms_id>"
|
xml_output " </test>"
|
}
|
|
switch -- $type {
|
PASS {
|
if {$prms_id} {
|
set message [concat $message "\t(PRMS $prms_id)"]
|
}
|
}
|
FAIL {
|
set exit_status 1
|
if {$prms_id} {
|
set message [concat $message "\t(PRMS $prms_id)"]
|
}
|
}
|
XPASS {
|
set exit_status 1
|
if { $xfail_prms != 0 } {
|
set message [concat $message "\t(PRMS $xfail_prms)"]
|
}
|
}
|
XFAIL {
|
if { $xfail_prms != 0 } {
|
set message [concat $message "\t(PRMS $xfail_prms)"]
|
}
|
}
|
KPASS {
|
set exit_status 1
|
if { $kfail_prms != 0 } {
|
set message [concat $message "\t(PRMS $kfail_prms)"]
|
}
|
}
|
KFAIL {
|
if { $kfail_prms != 0 } {
|
set message [concat $message "\t(PRMS: $kfail_prms)"]
|
}
|
}
|
UNTESTED {
|
# The only reason we look at the xfail/kfail stuff is to pick up
|
# `xfail_prms'.
|
if { $kfail_flag && $kfail_prms != 0 } {
|
set message [concat $message "\t(PRMS $kfail_prms)"]
|
} elseif { $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 {
|
set exit_status 1
|
# The only reason we look at the xfail/kfail stuff is to pick up
|
# `xfail_prms'.
|
if { $kfail_flag && $kfail_prms != 0 } {
|
set message [concat $message "\t(PRMS $kfail_prms)"]
|
} elseif { $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 {
|
# The only reason we look at the xfail/kfail stuff is to pick up
|
# `xfail_prms'.
|
if { $kfail_flag && $kfail_prms != 0 } {
|
set message [concat $message "\t(PRMS $kfail_prms)"]
|
} elseif { $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 != "" } {
|
set message [format "$type: %s: $message" "$multipass_name"]
|
} else {
|
set message "$type: $message"
|
}
|
clone_output "$message"
|
|
# If a command name exists in the $local_record_procs associative
|
# array for this type of result, then invoke it.
|
|
set lowcase_type [string tolower $type]
|
global local_record_procs
|
if {[info exists local_record_procs($lowcase_type)]} {
|
$local_record_procs($lowcase_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 kfail_flag 0
|
set xfail_prms 0
|
set kfail_prms 0
|
}
|
|
# Record that a test has passed.
|
#
|
proc pass { message } {
|
global xfail_flag kfail_flag compiler_conditional_xfail_data
|
|
# if we have a conditional xfail setup, then see if our compiler flags match
|
if {[ info exists compiler_conditional_xfail_data ]} {
|
if {[check_conditional_xfail $compiler_conditional_xfail_data]} {
|
set xfail_flag 1
|
}
|
unset compiler_conditional_xfail_data
|
}
|
|
if { $kfail_flag } {
|
record_test KPASS $message
|
} elseif { $xfail_flag } {
|
record_test XPASS $message
|
} else {
|
record_test PASS $message
|
}
|
}
|
|
# Record that a test has failed.
|
#
|
proc fail { message } {
|
global xfail_flag kfail_flag compiler_conditional_xfail_data
|
|
# if we have a conditional xfail setup, then see if our compiler flags match
|
if {[ info exists compiler_conditional_xfail_data ]} {
|
if {[check_conditional_xfail $compiler_conditional_xfail_data]} {
|
set xfail_flag 1
|
}
|
unset compiler_conditional_xfail_data
|
}
|
|
if { $kfail_flag } {
|
record_test KFAIL $message
|
} elseif { $xfail_flag } {
|
record_test XFAIL $message
|
} else {
|
record_test FAIL $message
|
}
|
}
|
|
# Record that a test that was expected to fail has passed unexpectedly.
|
#
|
proc xpass { message } {
|
record_test XPASS $message
|
}
|
|
# Record that a test that was expected to fail did indeed fail.
|
#
|
proc xfail { message } {
|
record_test XFAIL $message
|
}
|
|
# Record that a test for a known bug has passed unexpectedly.
|
#
|
proc kpass { bugid message } {
|
global kfail_flag kfail_prms
|
set kfail_flag 1
|
set kfail_prms $bugid
|
record_test KPASS $message
|
}
|
|
# Record that a test has failed due to a known bug.
|
#
|
proc kfail { bugid message } {
|
global kfail_flag kfail_prms
|
set kfail_flag 1
|
set kfail_prms $bugid
|
record_test KFAIL $message
|
}
|
|
# Set warning threshold.
|
#
|
proc set_warning_threshold { threshold } {
|
global warning_threshold
|
set warning_threshold $threshold
|
}
|
|
# Get warning threshold.
|
#
|
proc get_warning_threshold { } {
|
global 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
|
|
if { [llength $args] > 1 } {
|
set warncnt [lindex $args 1]
|
} else {
|
incr warncnt
|
}
|
set message [lindex $args 0]
|
|
clone_output "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
|
|
if { [llength $args] > 1 } {
|
set errcnt [lindex $args 1]
|
} else {
|
incr errcnt
|
}
|
set message [lindex $args 0]
|
|
clone_output "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"
|
}
|
|
# 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
|
}
|
|
# Set up the values in the test_counts array (name and initial
|
# totals).
|
#
|
proc init_testcounts { } {
|
global test_counts test_names
|
set test_counts(TOTAL,name) "testcases run"
|
set test_counts(PASS,name) "expected passes"
|
set test_counts(FAIL,name) "unexpected failures"
|
set test_counts(XFAIL,name) "expected failures"
|
set test_counts(XPASS,name) "unexpected successes"
|
set test_counts(KFAIL,name) "known failures"
|
set test_counts(KPASS,name) "unknown successes"
|
set test_counts(WARNING,name) "warnings"
|
set test_counts(ERROR,name) "errors"
|
set test_counts(UNSUPPORTED,name) "unsupported tests"
|
set test_counts(UNRESOLVED,name) "unresolved testcases"
|
set test_counts(UNTESTED,name) "untested testcases"
|
set j ""
|
|
foreach i [lsort [array names test_counts]] {
|
regsub ",.*$" "$i" "" i
|
if { $i == $j } {
|
continue
|
}
|
set test_counts($i,total) 0
|
lappend test_names $i
|
set j $i
|
}
|
}
|
|
# Increment NAME in the test_counts array; the amount to increment can
|
# be is optional (defaults to 1).
|
#
|
proc incr_count { name args } {
|
global test_counts
|
|
if { [llength $args] == 0 } {
|
set count 1
|
} else {
|
set count [lindex $args 0]
|
}
|
if {[info exists test_counts($name,count)]} {
|
incr test_counts($name,count) $count
|
incr test_counts($name,total) $count
|
} else {
|
perror "$name doesn't exist in incr_count"
|
}
|
}
|
