lib/framework.exp

   1 # Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc.
   2 #
   3 # This file is part of DejaGnu.
   4 #
   5 # DejaGnu is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # DejaGnu is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with DejaGnu; if not, write to the Free Software Foundation,
  17 # Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # This file was originally written by Rob Savoye <rob@welcomehome.org>.
  20
  21 ## Internal infrastructure
  22
  23 namespace eval ::dejagnu::group {
  24     variable names [list]
  25     variable files [list]
  26 }
  27
  28 proc ::dejagnu::group::check_name { name } {
  29     return [string is graph -strict $name]
  30 }
  31
  32 proc ::dejagnu::group::current {} {
  33     variable names
  34     return [join $names "/"]
  35 }
  36
  37 proc ::dejagnu::group::push { name file } {
  38     variable names
  39     variable files
  40     lappend names $name
  41     lappend files $file
  42 }
  43 proc ::dejagnu::group::pop { name file } {
  44     variable names
  45     variable files
  46
  47     if { $file ne [lindex $files end]
  48          || $name ne [lindex $names end] } {
  49         error "expected to close group {$name} from {$file}\n\
  50                    actually found group {[lindex $names end]}\
  51                         from {[lindex $files end]}"
  52     } else {
  53         set names [lreplace $names end end]
  54         set files [lreplace $files end end]
  55     }
  56 }
  57 proc ::dejagnu::group::pop_to_file { file } {
  58     variable names
  59     variable files
  60
  61     while { $file ne [lindex $files end] } {
  62         perror "closing forgotten group {[::dejagnu::group::current]}\
  63                         from {[lindex $files end]}" 0
  64         set names [lreplace $names end end]
  65         set files [lreplace $files end end]
  66         if { [llength $names] < 1 } {
  67             error "no more groups while unwinding to file $file"
  68         }
  69     }
  70 }
  71
  72 ## General code; not yet sorted under headings
  73
  74 # These variables are local to this file.
  75 # This or more warnings and a test fails.
  76 set warning_threshold 3
  77 # This or more errors and a test fails.
  78 set perror_threshold 1
  79
  80 proc mail_file { file to subject } {
  81     if {[file readable $file]} {
  82         catch "exec mail -s \"$subject\" $to < $file"
  83     }
  84 }
  85
  86 # Insert DTD for xml format checking.
  87 #
  88 proc insertdtd { } {
  89     xml_output "<!DOCTYPE testsuite \[
  90 <!-- testsuite.dtd -->
  91 <!ELEMENT testsuite (test | summary)+>
  92 <!ELEMENT test (input, output, result, name, prms_id )>
  93   <!ELEMENT input              (#PCDATA)>
  94   <!ELEMENT output             (#PCDATA)>
  95   <!ELEMENT result             (#PCDATA)>
  96   <!ELEMENT name               (#PCDATA)>
  97   <!ELEMENT prms_id            (#PCDATA)>
  98   <!ELEMENT summary            (result, description, total)>
  99   <!ELEMENT description        (#PCDATA)>
 100   <!ELEMENT total              (#PCDATA)>
 101 \]>"
 102 }
 103
 104 # Open the output logs.
 105 #
 106 proc open_logs { } {
 107     global outdir
 108     global tool
 109     global sum_file
 110     global xml_file
 111     global xml
 112
 113     if { $tool eq "" } {
 114         set tool testrun
 115     }
 116     catch "file delete -force -- $outdir/$tool.sum"
 117     set sum_file [open [file join $outdir $tool.sum] w]
 118     if { $xml } {
 119         catch "file delete -force -- $outdir/$tool.xml"
 120         set xml_file [open [file join $outdir $tool.xml] w]
 121         xml_output "<?xml version=\"1.1\"?>"
 122         insertdtd
 123         xml_output "<testsuite>"
 124     }
 125     catch "file delete -force -- $outdir/$tool.log"
 126     log_file -a $outdir/$tool.log
 127     verbose "Opening log files in $outdir"
 128     if { $tool eq "testrun" } {
 129         set tool ""
 130     }
 131     fconfigure $sum_file -buffering line
 132 }
 133
 134 # Close the output logs.
 135 #
 136 proc close_logs { } {
 137     global sum_file
 138     global xml
 139     global xml_file
 140
 141     if { $xml } {
 142         xml_output "</testsuite>"
 143         catch "close $xml_file"
 144     }
 145
 146     catch "close $sum_file"
 147 }
 148
 149 # Check build host triplet for PATTERN.
 150 # With no arguments it returns the triplet string.
 151 #
 152 proc isbuild { { pattern "" } } {
 153     global build_triplet
 154     global host_triplet
 155
 156     if {![info exists build_triplet]} {
 157         set build_triplet $host_triplet
 158     }
 159     if {$pattern eq ""} {
 160         return $build_triplet
 161     }
 162     verbose "Checking pattern \"$pattern\" with $build_triplet" 2
 163
 164     if {[string match $pattern $build_triplet]} {
 165         return 1
 166     } else {
 167         return 0
 168     }
 169 }
 170
 171 # Is $board remote? Return a non-zero value if so.
 172 #
 173 proc isremote { board } {
 174     verbose "calling isremote $board" 3
 175     return [is_remote $board]
 176 }
 177
 178 # Legacy library proc for isremote.
 179 #
 180 proc is_remote { board } {
 181     global host_board
 182     global target_list
 183
 184     verbose "calling is_remote $board" 3
 185     # Remove any target variant specifications from the name.
 186     set board [lindex [split $board "/"] 0]
 187
 188     # Map the host or build back into their short form.
 189     if { [board_info build name] eq $board } {
 190         set board "build"
 191     } elseif { [board_info host name] eq $board } {
 192         set board "host"
 193     }
 194
 195     # We're on the "build". The check for the empty string is just for
 196     # paranoia's sake--we shouldn't ever get one. "unix" is a magic
 197     # string that should really go away someday.
 198     if { $board eq "build" || $board eq "unix" || $board eq "" } {
 199         verbose "board is $board, not remote" 3
 200         return 0
 201     }
 202
 203     if { $board eq "host" } {
 204         if { [info exists host_board] && $host_board ne "" } {
 205             verbose "board is $board, is remote" 3
 206             return 1
 207         } else {
 208             verbose "board is $board, host is local" 3
 209             return 0
 210         }
 211     }
 212
 213     if { $board eq "target" } {
 214         global current_target_name
 215
 216         if {[info exists current_target_name]} {
 217             # This shouldn't happen, but we'll be paranoid anyway.
 218             if { $current_target_name ne "target" } {
 219                 return [is_remote $current_target_name]
 220             }
 221         }
 222         return 0
 223     }
 224     if {[board_info $board exists isremote]} {
 225         verbose "board is $board, isremote is [board_info $board isremote]" 3
 226         return [board_info $board isremote]
 227     }
 228     return 1
 229 }
 230
 231 # If this is a Canadian (3 way) cross. This means the tools are
 232 # being built with a cross compiler for another host.
 233 #
 234 proc is3way {} {
 235     global host_triplet
 236     global build_triplet
 237
 238     if {![info exists build_triplet]} {
 239         set build_triplet $host_triplet
 240     }
 241     verbose "Checking $host_triplet against $build_triplet" 2
 242     if { $build_triplet eq $host_triplet } {
 243         return 0
 244     }
 245     return 1
 246 }
 247
 248 # Check host triplet for PATTERN.
 249 # With no arguments it returns the triplet string.
 250 #
 251 proc ishost { { pattern "" } } {
 252     global host_triplet
 253
 254     if {$pattern eq ""} {
 255         return $host_triplet
 256     }
 257     verbose "Checking pattern \"$pattern\" with $host_triplet" 2
 258
 259     if {[string match $pattern $host_triplet]} {
 260         return 1
 261     } else {
 262         return 0
 263     }
 264 }
 265
 266 # Check target triplet for pattern.
 267 #
 268 # With no arguments it returns the triplet string.
 269 # Returns 1 if the target looked for, or 0 if not.
 270 #
 271 proc istarget { { args "" } } {
 272     global target_triplet
 273
 274     # if no arg, return the config string
 275     if {$args eq ""} {
 276         if {[info exists target_triplet]} {
 277             return $target_triplet
 278         } else {
 279             perror "No target configuration names found."
 280         }
 281     }
 282
 283     set triplet [lindex $args 0]
 284
 285     # now check against the canonical name
 286     if {[info exists target_triplet]} {
 287         verbose "Checking \"$triplet\" against \"$target_triplet\"" 2
 288         if {[string match $triplet $target_triplet]} {
 289             return 1
 290         }
 291     }
 292
 293     # nope, no match
 294     return 0
 295 }
 296
 297 # Check to see if we're running the tests in a native environment
 298 # Returns 1 if running native, 0 if on a target.
 299 #
 300 proc isnative { } {
 301     global target_triplet
 302     global build_triplet
 303
 304     return [string equal $build_triplet $target_triplet]
 305 }
 306
 307 # unknown -- called by expect if a proc is called that doesn't exist
 308 #
 309 # Rename unknown to tcl_unknown so that we can wrap tcl_unknown.
 310 # This allows Tcl package autoloading to work in the modern age.
 311
 312 rename ::unknown ::tcl_unknown
 313 proc unknown { args } {
 314     global errorCode
 315     global errorInfo
 316     global exit_status
 317
 318     set code [catch {uplevel 1 ::tcl_unknown $args} msg]
 319     if { $code != 0 } {
 320         set ret_cmd [list return -code $code]
 321
 322         # If the command now exists, then it was autoloaded.  We are here,
 323         # therefore invoking the autoloaded command raised an error.
 324         # Silently propagate errors from autoloaded procedures, but
 325         # complain noisily about undefined commands.
 326         set have_it_now [llength [info commands [lindex $args 0]]]
 327
 328         if { ! $have_it_now } {
 329             clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist."
 330             set exit_status 2
 331         }
 332
 333         if { [info exists errorCode] } {
 334             lappend ret_cmd -errorcode $errorCode
 335             if { ! $have_it_now } {
 336                 send_error "The error code is $errorCode\n"
 337             }
 338         }
 339         if { [info exists errorInfo] } {
 340             # omitting errorInfo from the propagated error makes this proc
 341             # invisible with the backtrace pointing directly to the problem
 342             if { ! $have_it_now } {
 343                 send_error "The info on the error is:\n$errorInfo\n"
 344             }
 345         }
 346
 347         lappend ret_cmd $msg
 348
 349         eval $ret_cmd
 350     } else {
 351         # Propagate return value.
 352         return $msg
 353     }
 354 }
 355
 356 # Print output to stdout (or stderr) and to log file
 357 #
 358 # If the --all flag (-a) option was used then all messages go the the screen.
 359 # Without this, all messages that start with a keyword are written only to the
 360 # detail log file.  All messages that go to the screen will also appear in the
 361 # detail log.  This should only be used by the framework itself using pass,
 362 # fail, xpass, xfail, kpass, kfail, warning, perror, note, untested, unresolved,
 363 # or unsupported procedures.
 364 #
 365 proc clone_output { message } {
 366     global sum_file
 367     global all_flag
 368
 369     if { $sum_file ne "" } {
 370         puts $sum_file $message
 371     }
 372
 373     regsub "^\[ \t\]*(\[^ \t\]+).*$" $message "\\1" firstword
 374     switch -glob -- $firstword {
 375         "PASS:" -
 376         "XFAIL:" -
 377         "KFAIL:" -
 378         "UNRESOLVED:" -
 379         "UNSUPPORTED:" -
 380         "UNTESTED:" {
 381             if {$all_flag} {
 382                 send_user -- "$message\n"
 383                 return $message
 384             } else {
 385                 send_log -- "$message\n"
 386             }
 387         }
 388         "ERROR:" -
 389         "WARNING:" -
 390         "NOTE:" {
 391             send_error -- "$message\n"
 392             return $message
 393         }
 394         default {
 395             send_user -- "$message\n"
 396             return $message
 397         }
 398     }
 399 }
 400
 401 # Reset a few counters.
 402 #
 403 proc reset_vars {} {
 404     global test_names test_counts
 405     global warncnt errcnt
 406
 407     # other miscellaneous variables
 408     global prms_id
 409     global bug_id
 410
 411     # reset them all
 412     set prms_id 0
 413     set bug_id  0
 414     set warncnt 0
 415     set errcnt  0
 416     foreach x $test_names {
 417         set test_counts($x,count) 0
 418     }
 419
 420     # Variables local to this file.
 421     global warning_threshold perror_threshold
 422     set warning_threshold 3
 423     set perror_threshold 1
 424 }
 425
 426 proc log_and_exit {} {
 427     global exit_status
 428     global tool mail_logs outdir mailing_list
 429
 430     log_summary total
 431     # extract version number
 432     if {[info procs ${tool}_version] ne ""} {
 433         if {[catch ${tool}_version output]} {
 434             warning "${tool}_version failed:\n$output"
 435         }
 436     }
 437     if {[llength $::dejagnu::error::list] > 0} {
 438         # print errors again at end of output
 439         foreach { cell } $::dejagnu::error::list {
 440             clone_output "ERROR: [string repeat - 43]"
 441             clone_output "ERROR: in testcase [lindex $cell 0]"
 442             clone_output "ERROR:  [lindex $cell 1]"
 443             clone_output "ERROR:  tcl error code [lindex $cell 2]"
 444             clone_output "ERROR: \
 445                 tcl error info:\n[lindex $cell 3]\n[string repeat - 50]"
 446         }
 447     }
 448     close_logs
 449     verbose -log "runtest completed at [timestamp -format %c]"
 450     if {$mail_logs} {
 451         if { $tool eq "" } {
 452             set tool testrun
 453         }
 454         mail_file $outdir/$tool.sum $mailing_list "Dejagnu Summary Log"
 455     }
 456     remote_close host
 457     remote_close target
 458     exit $exit_status
 459 }
 460
 461 # Emit an XML tag, but escape XML special characters in the body.
 462 proc xml_tag { tag body } {
 463     set escapes { < &lt; > &gt; & &amp; \" &quot; ' &apos; }
 464     for {set i 1} {$i < 32} {incr i} {
 465         if {[lsearch [list 9 10 13] $i] >= 0} {
 466             # skip valid XML whitespace chars
 467             continue
 468         }
 469         # Append non-printable character
 470         lappend escapes [format %c $i]
 471         # .. and then the corresponding XML escape
 472         lappend escapes &#x[format %x $i]\;
 473     }
 474     return <$tag>[string map $escapes $body]</$tag>
 475 }
 476
 477 proc xml_output { message } {
 478     global xml_file
 479     if { $xml_file ne "" } {
 480         puts $xml_file $message
 481     }
 482 }
 483
 484 # Print summary of all pass/fail counts.
 485 #
 486 proc log_summary { args } {
 487     global tool
 488     global sum_file
 489     global xml_file
 490     global xml
 491     global exit_status
 492     global mail_logs
 493     global outdir
 494     global mailing_list
 495     global current_target_name
 496     global test_counts
 497
 498     if { [llength $args] == 0 } {
 499         set which "count"
 500     } else {
 501         set which [lindex $args 0]
 502     }
 503
 504     if { [llength $args] == 0 } {
 505         clone_output "\n\t\t=== $tool Summary for $current_target_name ===\n"
 506     } else {
 507         clone_output "\n\t\t=== $tool Summary ===\n"
 508     }
 509
 510     foreach x { PASS FAIL XPASS XFAIL KPASS KFAIL UNRESOLVED UNTESTED UNSUPPORTED } {
 511         set val $test_counts($x,$which)
 512         if { $val > 0 } {
 513             set mess "# of $test_counts($x,name)"
 514             if { $xml } {
 515                 xml_output "  <summary>"
 516                 xml_output "    [xml_tag result $x]"
 517                 xml_output "    [xml_tag description $mess]"
 518                 xml_output "    [xml_tag total $val]"
 519                 xml_output "  </summary>"
 520             }
 521             if { [string length $mess] < 24 } {
 522                 append mess "\t"
 523             }
 524             clone_output "$mess\t$val"
 525         }
 526     }
 527 }
 528
 529 # Setup a flag to control whether a failure is expected or not
 530 #
 531 # Multiple target triplet patterns can be specified for targets
 532 # for which the test fails.  A bug report ID can be specified,
 533 # which is a string without '-'.
 534 #
 535 proc setup_xfail { args } {
 536     global xfail_flag
 537     global xfail_prms
 538
 539     set xfail_prms 0
 540     set argc [ llength $args ]
 541     for { set i 0 } { $i < $argc } { incr i } {
 542         set sub_arg [ lindex $args $i ]
 543         # is a prms number. we assume this is a string with no '-' characters
 544         if {[regexp "^\[^\-\]+$" $sub_arg]} {
 545             set xfail_prms $sub_arg
 546             continue
 547         }
 548         if {[istarget $sub_arg]} {
 549             set xfail_flag 1
 550             continue
 551         }
 552     }
 553 }
 554
 555 # Setup a flag to control whether it is a known failure.
 556 #
 557 # A bug report ID _MUST_ be specified, and is the first argument.
 558 # It still must be a string without '-' so we can be sure someone
 559 # did not just forget it and we end-up using a target triple as
 560 # bug id.
 561 #
 562 # Multiple target triplet patterns can be specified for targets
 563 # for which the test is known to fail.
 564 #
 565 proc setup_kfail { args } {
 566     global kfail_flag
 567     global kfail_prms
 568
 569     set kfail_prms 0
 570     set argc [ llength $args ]
 571     for { set i 0 } { $i < $argc } { incr i } {
 572         set sub_arg [ lindex $args $i ]
 573         # is a prms number. we assume this is a string with no '-' characters
 574         if {[regexp "^\[^\-\]+$" $sub_arg]} {
 575             set kfail_prms $sub_arg
 576             continue
 577         }
 578         if {[istarget $sub_arg]} {
 579             set kfail_flag 1
 580             continue
 581         }
 582     }
 583
 584     if {$kfail_prms == 0} {
 585         perror "Attempt to set a kfail without specifying bug tracking id"
 586     }
 587 }
 588
 589 # Check to see if a conditional xfail is triggered.
 590 #       message {targets} {include} {exclude}
 591 #
 592 proc check_conditional_xfail { args } {
 593     global compiler_flags
 594
 595     set all_args [lindex $args 0]
 596
 597     set message [lindex $all_args 0]
 598
 599     set target_list [lindex $all_args 1]
 600     verbose "Limited to targets: $target_list" 3
 601
 602     # get the list of flags to look for
 603     set includes [lindex $all_args 2]
 604     verbose "Will search for options $includes" 3
 605
 606     # get the list of flags to exclude
 607     if { [llength $all_args] > 3 } {
 608         set excludes [lindex $all_args 3]
 609         verbose "Will exclude for options $excludes" 3
 610     } else {
 611         set excludes ""
 612     }
 613
 614     # loop through all the targets, checking the options for each one
 615     verbose "Compiler flags are: $compiler_flags" 2
 616
 617     set incl_hit 0
 618     set excl_hit 0
 619     foreach targ $target_list {
 620         if {[istarget $targ]} {
 621             # look through the compiler options for flags we want to see
 622             # this is really messy cause each set of options to look for
 623             # may also be a list. We also want to find each element of the
 624             # list, regardless of order to make sure they're found.
 625             # So we look for lists in side of lists, and make sure all
 626             # the elements match before we decide this is legit.
 627             # Se we 'incl_hit' to 1 before the loop so that if the 'includes'
 628             # list is empty, this test will report a hit.  (This can be
 629             # useful if a target will always fail unless certain flags,
 630             # specified in the 'excludes' list, are used.)
 631             set incl_hit 1
 632             for { set i 0 } { $i < [llength $includes] } { incr i } {
 633                 set incl_hit 0
 634                 set opt [lindex $includes $i]
 635                 verbose "Looking for $opt to include in the compiler flags" 2
 636                 foreach j $opt {
 637                     if {[string match "* $j *" $compiler_flags]} {
 638                         verbose "Found $j to include in the compiler flags" 2
 639                         incr incl_hit
 640                     }
 641                 }
 642                 # if the number of hits we get is the same as the number of
 643                 # specified options, then we got a match
 644                 if {$incl_hit == [llength $opt]} {
 645                     break
 646                 } else {
 647                     set incl_hit 0
 648                 }
 649             }
 650             # look through the compiler options for flags we don't
 651             # want to see
 652             for { set i 0 } { $i < [llength $excludes] } { incr i } {
 653                 set excl_hit 0
 654                 set opt [lindex $excludes $i]
 655                 verbose "Looking for $opt to exclude in the compiler flags" 2
 656                 foreach j $opt {
 657                     if {[string match "* $j *" $compiler_flags]} {
 658                         verbose "Found $j to exclude in the compiler flags" 2
 659                         incr excl_hit
 660                     }
 661                 }
 662                 # if the number of hits we get is the same as the number of
 663                 # specified options, then we got a match
 664                 if {$excl_hit == [llength $opt]} {
 665                     break
 666                 } else {
 667                     set excl_hit 0
 668                 }
 669             }
 670
 671             # if we got a match for what to include, but didn't find any reasons
 672             # to exclude this, then we got a match! So return one to turn this into
 673             # an expected failure.
 674             if {$incl_hit && ! $excl_hit } {
 675                 verbose "This is a conditional match" 2
 676                 return 1
 677             } else {
 678                 verbose "This is not a conditional match" 2
 679                 return 0
 680             }
 681         }
 682     }
 683     return 0
 684 }
 685
 686 # Clear the xfail flag for a particular target.
 687 #
 688 proc clear_xfail { args } {
 689     global xfail_flag
 690     global xfail_prms
 691
 692     set argc [ llength $args ]
 693     for { set i 0 } { $i < $argc } { incr i } {
 694         set sub_arg [ lindex $args $i ]
 695         switch -glob -- $sub_arg {
 696             "*-*-*" {                   # is a configuration triplet
 697                 if {[istarget $sub_arg]} {
 698                     set xfail_flag 0
 699                     set xfail_prms 0
 700                 }
 701                 continue
 702             }
 703         }
 704     }
 705 }
 706
 707 # Clear the kfail flag for a particular target.
 708 #
 709 proc clear_kfail { args } {
 710     global kfail_flag
 711     global kfail_prms
 712
 713     set argc [ llength $args ]
 714     for { set i 0 } { $i < $argc } { incr i } {
 715         set sub_arg [ lindex $args $i ]
 716         switch -glob -- $sub_arg {
 717             "*-*-*" {                   # is a configuration triplet
 718                 if {[istarget $sub_arg]} {
 719                     set kfail_flag 0
 720                     set kfail_prms 0
 721                 }
 722                 continue
 723             }
 724         }
 725     }
 726 }
 727
 728 # Record that a test has passed or failed (perhaps unexpectedly).
 729 # This is an internal procedure, only used in this file.
 730 #
 731 proc record_test { type message args } {
 732     global exit_status
 733     global xml
 734     global prms_id bug_id
 735     global xfail_flag xfail_prms
 736     global kfail_flag kfail_prms
 737     global errcnt warncnt
 738     global warning_threshold perror_threshold
 739     global pf_prefix
 740
 741     if { [llength $args] > 0 } {
 742         set count [lindex $args 0]
 743     } else {
 744         set count 1
 745     }
 746     if {[info exists pf_prefix]} {
 747         set message [concat $pf_prefix " " $message]
 748     }
 749
 750     # If we have too many warnings or errors,
 751     # the output of the test can't be considered correct.
 752     if { $warning_threshold > 0 && $warncnt >= $warning_threshold
 753          || $perror_threshold > 0 && $errcnt >= $perror_threshold } {
 754         verbose "Error/Warning threshold exceeded: \
 755                  $errcnt $warncnt (max. $perror_threshold $warning_threshold)"
 756         set type UNRESOLVED
 757     }
 758
 759     incr_count $type
 760
 761     if { $xml } {
 762         global errorInfo
 763         set error ""
 764         if {[info exists errorInfo]} {
 765             set error $errorInfo
 766         }
 767         global expect_out
 768         set rio { "" "" }
 769         if { [catch { set rio [split $expect_out(buffer) "\n"] } result]} {
 770             #do nothing - leave as { "" "" }
 771         }
 772
 773         set output ""
 774         set output "expect_out(buffer)"
 775         xml_output "  <test>"
 776         xml_output "    [xml_tag input [string trimright [lindex $rio 0]]]"
 777         xml_output "    [xml_tag output [string trimright [lindex $rio 1]]]"
 778         xml_output "    [xml_tag result $type]"
 779         xml_output "    [xml_tag name $message]"
 780         xml_output "    [xml_tag prms_id $prms_id]"
 781         xml_output "  </test>"
 782     }
 783
 784     switch -- $type {
 785         PASS {
 786             if {$prms_id} {
 787                 set message [concat $message "\t(PRMS $prms_id)"]
 788             }
 789         }
 790         FAIL {
 791             set exit_status 1
 792             if {$prms_id} {
 793                 set message [concat $message "\t(PRMS $prms_id)"]
 794             }
 795         }
 796         XPASS {
 797             set exit_status 1
 798             if { $xfail_prms != 0 } {
 799                 set message [concat $message "\t(PRMS $xfail_prms)"]
 800             }
 801         }
 802         XFAIL {
 803             if { $xfail_prms != 0 } {
 804                 set message [concat $message "\t(PRMS $xfail_prms)"]
 805             }
 806         }
 807         KPASS {
 808             set exit_status 1
 809             if { $kfail_prms != 0 } {
 810                 set message [concat $message "\t(PRMS $kfail_prms)"]
 811             }
 812         }
 813         KFAIL {
 814             if { $kfail_prms != 0 } {
 815                 set message [concat $message "\t(PRMS: $kfail_prms)"]
 816             }
 817         }
 818         UNTESTED {
 819             # The only reason we look at the xfail/kfail stuff is to pick up
 820             # `xfail_prms'.
 821             if { $kfail_flag && $kfail_prms != 0 } {
 822                 set message [concat $message "\t(PRMS $kfail_prms)"]
 823             } elseif { $xfail_flag && $xfail_prms != 0 } {
 824                 set message [concat $message "\t(PRMS $xfail_prms)"]
 825             } elseif { $prms_id } {
 826                 set message [concat $message "\t(PRMS $prms_id)"]
 827             }
 828         }
 829         UNRESOLVED {
 830             set exit_status 1
 831             # The only reason we look at the xfail/kfail stuff is to pick up
 832             # `xfail_prms'.
 833             if { $kfail_flag && $kfail_prms != 0 } {
 834                 set message [concat $message "\t(PRMS $kfail_prms)"]
 835             } elseif { $xfail_flag && $xfail_prms != 0 } {
 836                 set message [concat $message "\t(PRMS $xfail_prms)"]
 837             } elseif { $prms_id } {
 838                 set message [concat $message "\t(PRMS $prms_id)"]
 839             }
 840         }
 841         UNSUPPORTED {
 842             # The only reason we look at the xfail/kfail stuff is to pick up
 843             # `xfail_prms'.
 844             if { $kfail_flag && $kfail_prms != 0 } {
 845                 set message [concat $message "\t(PRMS $kfail_prms)"]
 846             } elseif { $xfail_flag && $xfail_prms != 0 } {
 847                 set message [concat $message "\t(PRMS $xfail_prms)"]
 848             } elseif { $prms_id } {
 849                 set message [concat $message "\t(PRMS $prms_id)"]
 850             }
 851         }
 852         default {
 853             perror "record_test called with bad type `$type'"
 854             set errcnt 0
 855             return
 856         }
 857     }
 858
 859     if { $bug_id } {
 860         set message [concat $message "\t(BUG $bug_id)"]
 861     }
 862
 863     global multipass_name
 864     if { $multipass_name ne "" } {
 865         set message [format "%s: %s: %s" $type $multipass_name $message]
 866     } else {
 867         set message "$type: $message"
 868     }
 869     clone_output $message
 870
 871     # If a command name exists in the $local_record_procs associative
 872     # array for this type of result, then invoke it.
 873
 874     set lowcase_type [string tolower $type]
 875     global local_record_procs
 876     if {[info exists local_record_procs($lowcase_type)]} {
 877         $local_record_procs($lowcase_type) $message
 878     }
 879
 880     # Reset these so they're ready for the next test case.  We don't reset
 881     # prms_id or bug_id here.  There may be multiple tests for them.  Instead
 882     # they are reset in the main loop after each test.  It is also the
 883     # testsuite driver's responsibility to reset them after each testcase.
 884     set warncnt 0
 885     set errcnt 0
 886     set xfail_flag 0
 887     set kfail_flag 0
 888     set xfail_prms 0
 889     set kfail_prms 0
 890 }
 891
 892 # Record that a test has passed.
 893 #
 894 proc pass { message } {
 895     global xfail_flag kfail_flag compiler_conditional_xfail_data
 896
 897     # if we have a conditional xfail setup, then see if our compiler flags match
 898     if {[ info exists compiler_conditional_xfail_data ]} {
 899         if {[check_conditional_xfail $compiler_conditional_xfail_data]} {
 900             set xfail_flag 1
 901         }
 902         unset compiler_conditional_xfail_data
 903     }
 904
 905     if { $kfail_flag } {
 906         record_test KPASS $message
 907     } elseif { $xfail_flag } {
 908         record_test XPASS $message
 909     } else {
 910         record_test PASS $message
 911     }
 912 }
 913
 914 # Record that a test has failed.
 915 #
 916 proc fail { message } {
 917     global xfail_flag kfail_flag compiler_conditional_xfail_data
 918
 919     # if we have a conditional xfail setup, then see if our compiler flags match
 920     if {[ info exists compiler_conditional_xfail_data ]} {
 921         if {[check_conditional_xfail $compiler_conditional_xfail_data]} {
 922             set xfail_flag 1
 923         }
 924         unset compiler_conditional_xfail_data
 925     }
 926
 927     if { $kfail_flag } {
 928         record_test KFAIL $message
 929     } elseif { $xfail_flag } {
 930         record_test XFAIL $message
 931     } else {
 932         record_test FAIL $message
 933     }
 934 }
 935
 936 # Record that a test that was expected to fail has passed unexpectedly.
 937 #
 938 proc xpass { message } {
 939     record_test XPASS $message
 940 }
 941
 942 # Record that a test that was expected to fail did indeed fail.
 943 #
 944 proc xfail { message } {
 945     record_test XFAIL $message
 946 }
 947
 948 # Record that a test for a known bug has passed unexpectedly.
 949 #
 950 proc kpass { bugid message } {
 951     global kfail_flag kfail_prms
 952     set kfail_flag 1
 953     set kfail_prms $bugid
 954     record_test KPASS $message
 955 }
 956
 957 # Record that a test has failed due to a known bug.
 958 #
 959 proc kfail { bugid message } {
 960     global kfail_flag kfail_prms
 961     set kfail_flag 1
 962     set kfail_prms $bugid
 963     record_test KFAIL $message
 964 }
 965
 966 # Set warning threshold.
 967 #
 968 proc set_warning_threshold { threshold } {
 969     global warning_threshold
 970     set warning_threshold $threshold
 971 }
 972
 973 # Get warning threshold.
 974 #
 975 proc get_warning_threshold { } {
 976     global warning_threshold
 977     return $warning_threshold
 978 }
 979
 980 # Prints warning messages.
 981 # These are warnings from the framework, not from the tools being
 982 # tested.  It takes a string, and an optional number and returns
 983 # nothing.
 984 #
 985 proc warning { args } {
 986     global warncnt
 987
 988     if { [llength $args] > 1 } {
 989         set warncnt [lindex $args 1]
 990     } else {
 991         incr warncnt
 992     }
 993     set message [lindex $args 0]
 994
 995     clone_output "WARNING: $message"
 996
 997     global errorInfo
 998     if {[info exists errorInfo]} {
 999         unset errorInfo
1000     }
1001 }
1002
1003 # Prints error messages.
1004 # These are errors from the framework, not from the tools being
1005 # tested.  It takes a string, and an optional number and returns
1006 # nothing.
1007 #
1008 proc perror { args } {
1009     global errcnt
1010
1011     if { [llength $args] > 1 } {
1012         set errcnt [lindex $args 1]
1013     } else {
1014         incr errcnt
1015     }
1016     set message [lindex $args 0]
1017
1018     clone_output "ERROR: $message"
1019
1020     global errorInfo
1021     if {[info exists errorInfo]} {
1022         unset errorInfo
1023     }
1024 }
1025
1026 # Prints informational messages.
1027 #
1028 # These are messages from the framework, not from the tools being
1029 # tested.  This means that it is currently illegal to call this proc
1030 # outside of dejagnu proper.
1031 #
1032 proc note { message } {
1033     clone_output "NOTE: $message"
1034 }
1035
1036 # untested -- mark the test case as untested.
1037 #
1038 proc untested { message } {
1039     record_test UNTESTED $message
1040 }
1041
1042 # Mark the test case as unresolved.
1043 #
1044 proc unresolved { message } {
1045     record_test UNRESOLVED $message
1046 }
1047
1048 # Mark the test case as unsupported.
1049 # Usually this is used for a test that is missing OS support.
1050 #
1051 proc unsupported { message } {
1052     record_test UNSUPPORTED $message
1053 }
1054
1055 # Set up the values in the test_counts array (name and initial
1056 # totals).
1057 #
1058 proc init_testcounts { } {
1059     global test_counts test_names
1060     set test_counts(TOTAL,name) "testcases run"
1061     set test_counts(PASS,name) "expected passes"
1062     set test_counts(FAIL,name) "unexpected failures"
1063     set test_counts(XFAIL,name) "expected failures"
1064     set test_counts(XPASS,name) "unexpected successes"
1065     set test_counts(KFAIL,name) "known failures"
1066     set test_counts(KPASS,name) "unknown successes"
1067     set test_counts(WARNING,name) "warnings"
1068     set test_counts(ERROR,name) "errors"
1069     set test_counts(UNSUPPORTED,name) "unsupported tests"
1070     set test_counts(UNRESOLVED,name) "unresolved testcases"
1071     set test_counts(UNTESTED,name) "untested testcases"
1072     set j ""
1073
1074     foreach i [lsort [array names test_counts]] {
1075         regsub ",.*$" $i "" i
1076         if { $i == $j } {
1077             continue
1078         }
1079         set test_counts($i,total) 0
1080         lappend test_names $i
1081         set j $i
1082     }
1083 }
1084
1085 # Increment NAME in the test_counts array; the amount to increment can
1086 # be is optional (defaults to 1).
1087 #
1088 proc incr_count { name args } {
1089     global test_counts
1090
1091     if { [llength $args] == 0 } {
1092         set count 1
1093     } else {
1094         set count [lindex $args 0]
1095     }
1096     if {[info exists test_counts($name,count)]} {
1097         incr test_counts($name,count) $count
1098         incr test_counts($name,total) $count
1099     } else {
1100         perror "$name doesn't exist in incr_count"
1101     }
1102 }
1103
1104 ## API implementations and multiplex calls
1105
1106 # Return or provide information about the current testsuite.  (multiplex)
1107 #
1108 proc testsuite { subcommand args } {
1109     if { $subcommand eq "file" } {
1110         testsuite_file $args
1111     } elseif { $subcommand eq "can" } {
1112         testsuite_can $args
1113     } else {
1114         error "unknown \"testsuite\" command: testsuite $subcommand $args"
1115     }
1116 }
1117 namespace eval ::dejagnu {}
1118
1119 # Feature test
1120 #
1121 proc testsuite_can { argv } {
1122     verbose "entering testsuite can $argv" 3
1123
1124     if { [lindex $argv 0] eq "call" } {
1125         set call [lrange $argv 1 end]
1126         set result [info exists ::dejagnu::apilist($call)]
1127     } else {
1128         error "unknown feature test:  testsuite can $argv"
1129     }
1130
1131     verbose "leaving testsuite can: $result" 3
1132     return $result
1133 }
1134 array set ::dejagnu::apilist { {testsuite can call} 1 }
1135
1136 # Return a full file name in or near the testsuite
1137 #
1138 proc testsuite_file { argv } {
1139     global testsuitedir testbuilddir testdir
1140     verbose "entering testsuite file $argv" 3
1141     set argc [llength $argv]
1142     set dir_must_exist true
1143     set basedir $testsuitedir
1144     for { set argi 0 } { $argi < $argc } { incr argi } {
1145         set arg [lindex $argv $argi]
1146         if { $arg eq "--" } { # explicit end of arguments
1147             break
1148         } elseif { $arg eq "-object" } {
1149             set basedir $testbuilddir
1150         } elseif { $arg eq "-source" } {
1151             set basedir $testsuitedir
1152         } elseif { $arg eq "-top" } {
1153             set dirtail ""
1154         } elseif { $arg eq "-test" } {
1155             set dirtail $testdir
1156         } elseif { $arg eq "-hypothetical" } {
1157             set dir_must_exist false
1158         } elseif { [string match "-*" $arg] } {
1159             error "testsuite file: unrecognized flag [lindex $argv $argi]"
1160         } else { # implicit end of arguments
1161             break
1162         }
1163     }
1164     if { [lindex $argv $argi] eq "--" } { incr argi }
1165     if { ![info exists dirtail] } {
1166         error "testsuite file requires one of -top|-test\n\
1167                    but was given: $argv"
1168     }
1169     if { $dirtail ne "" } {
1170         set dirtail [relative_filename $testsuitedir $dirtail]
1171     }
1172     set result [eval [list file join $basedir $dirtail] [lrange $argv $argi end]]
1173
1174     verbose "implying: [file dirname $result]" 3
1175     if { $dir_must_exist && ![file isdirectory [file dirname $result]] } {
1176         if { $basedir eq $testbuilddir } {
1177             file mkdir [file dirname $result]
1178             verbose "making directory" 3
1179         } else {
1180             error "directory '[file dirname $result]' does not exist"
1181         }
1182     }
1183
1184     verbose "leaving testsuite file: $result" 3
1185     return $result
1186 }
1187 array set ::dejagnu::apilist { {testsuite file} 1 }
1188
1189 # Return or provide information about the current dynamic state.  (multiplex)
1190 #
1191 proc testcase { subcommand args } {
1192     if { $subcommand eq "group" } {
1193         testcase_group $args
1194     } else {
1195         error "unknown \"testcase\" command: testcase $subcommand $args"
1196     }
1197 }
1198
1199 # Indicate group boundaries or return current group
1200 #
1201 proc testcase_group { argv } {
1202     verbose "entering testcase group $argv" 3
1203     set argc [llength $argv]
1204
1205     if { $argc == 0 } {
1206         set result [::dejagnu::group::current]
1207     } else {
1208         set what [lindex $argv 0]
1209         set name [lindex $argv 1]
1210
1211         if { $what eq "begin" } {
1212             if { ![::dejagnu::group::check_name $name] } {
1213                 error "group name '$name' is not valid"
1214             }
1215             ::dejagnu::group::push $name [uplevel 2 info script]
1216             set result $name
1217         } elseif { $what eq "end" } {
1218             if { ![::dejagnu::group::check_name $name] } {
1219                 error "group name '$name' is not valid"
1220             }
1221             ::dejagnu::group::pop $name [uplevel 2 info script]
1222             set result $name
1223         } elseif { $what eq "eval" } {
1224             if { ![::dejagnu::group::check_name $name] } {
1225                 error "group name '$name' is not valid"
1226             }
1227             ::dejagnu::group::push $name [uplevel 2 info script]
1228             set result [uplevel 2 [lindex $argv 2]]
1229             ::dejagnu::group::pop $name [uplevel 2 info script]
1230         } else {
1231             error "unknown group operation: testcase group $argv"
1232         }
1233     }
1234
1235     verbose "leaving testcase group: $result" 3
1236     return $result
1237 }
1238 array set ::dejagnu::apilist {
1239     {testcase group} 1
1240     {testcase group begin} 1 {testcase group end} 1
1241     {testcase group eval}  1
1242 }