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