home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / dejagnu / framework.exp < prev    next >
Encoding:
Text File  |  1996-10-12  |  14.6 KB  |  676 lines
  1. # Copyright (C) 1988, 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2 of the License, or
  6. # (at your option) any later version.
  7. # 
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12. # 
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  16.  
  17. # Please email any bugs, comments, and/or additions to this file to:
  18. # bug-dejagnu@prep.ai.mit.edu
  19.  
  20. # This file was written by Rob Savoye. (rob@cygnus.com)
  21. #
  22.  
  23. proc mail_file { file to subject } {
  24.     if [file readable $file] then {
  25.     catch "exec mail -s \"$subject\" $to < $file"
  26.     }
  27. }
  28.  
  29. #
  30. # open_logs -- open the output logs
  31. #
  32. proc open_logs { } {
  33.     global outdir
  34.     global tool
  35.     global sum_file
  36.     
  37.     catch "exec rm -f $outdir/$tool.sum"
  38.     set sum_file [open "$outdir/$tool.sum" w]
  39.     catch "exec rm -f $outdir/$tool.log"
  40.     log_file -a "$outdir/$tool.log"
  41.     verbose "Opening log files in $outdir"
  42. }
  43.  
  44.  
  45. #
  46. # close_logs -- close the output logs
  47. #
  48. proc close_logs { } {
  49.     global sum_file
  50.     
  51.     catch "close $sum_file"
  52. }
  53.  
  54. #
  55. # ishost -- check  host triplet for pattern. With no arguments
  56. #             it returns the triplet string.
  57. #
  58. proc ishost { args } {
  59.     global host_triplet
  60.     
  61.     if [string match "" $args] then {
  62.     return $host_triplet
  63.     }
  64.     verbose "Checking pattern \"$args\" with $host_triplet"
  65.     
  66.     if [string match "$args" $host_triplet] then {
  67.     return 1
  68.     } else {
  69.     return 0
  70.     }
  71. }
  72.  
  73. #
  74. # istarget -- check target triplet for pattern. With no arguments
  75. #             it returns the triplet string.
  76. #             returns 1 if the target looked for, or
  77. #                     0 if not.
  78. #
  79. proc istarget { args } {
  80.     global target_triplet
  81.     
  82.     # if no arg, return the config string
  83.     if [string match "" $args] then {
  84.     if [info exists target_triplet] then {
  85.         return $target_triplet
  86.     } else {
  87.         perror "No target configuration names found."
  88.     }
  89.     }
  90.  
  91.     # now check against the cannonical name
  92.     if [info exists target_triplet] then {
  93.     verbose "Checking \"$args\" against \"$target_triplet\"" 2
  94.     if [string match "$args" $target_triplet] then {
  95.         return 1
  96.     }
  97.     }
  98.  
  99.     # nope, no match
  100.     return 0
  101. }
  102.  
  103. #
  104. # isnative --    check to see if we're running the tests in a native
  105. #        environment.
  106. #        returns 1 if it is running native
  107. #            0 if on a target.
  108. #
  109. proc isnative { } {
  110.     global target_triplet
  111.     global host_triplet
  112.     
  113.     if [string match $host_triplet $target_triplet] then {
  114.     return 1
  115.     }
  116.     return 0
  117. }
  118.  
  119. #
  120. # unknown -- called by expect if a proc is called that doesn't exist
  121. #
  122. proc unknown { args } {
  123.     global errorCode
  124.     global errorInfo
  125.     global exit_status
  126.     
  127.     clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist"
  128.     if [info exists errorCode] then {
  129.         send_error "The error code is $errorCode\n"
  130.     }
  131.     if [info exists errorInfo] then {
  132.         send_error "The info on the error is: \n$errorInfo\n"
  133.     }
  134.     log_summary
  135.     close_logs
  136.     cleanup
  137.     exit $exit_status
  138. }
  139.  
  140. #
  141. # clone_output -- print output to stdout and to log file
  142. #                 if the --all_flag (-a) option was used then all
  143. #                 messages go the the screen. Without this, all messages
  144. #                 that start with a keyword are written only to the detail
  145. #                 log file. All messages that go to the screen will also
  146. #                 appear in the detail log. This should only be used by
  147. #                 the framework itself using pass, fail, xfail, xpass,
  148. #                 warning, untested, unresolved, unsupported, or error
  149. #                 procedures.
  150. #
  151. proc clone_output { message } {
  152.     global sum_file
  153.     global all_flag
  154.     
  155.     case [lindex $message 0] in {
  156.     {"PASS:" "XFAIL:" "UNRESOLVED:" "UNSUPPORTED:" "UNTESTED:"}  {
  157.         if $all_flag then {
  158.         send_user  "$message\n"
  159.         } else {
  160.         send_log "$message\n"
  161.         }
  162.     }
  163.     {"ERROR:" "WARNING:"} {
  164.         send_error "$message\n"
  165.     }
  166.     default  {
  167.         send_user  "$message\n"
  168.     }
  169.     }
  170.     puts $sum_file "$message"
  171. }
  172.  
  173. #
  174. # reset_vars
  175. #    reset all globally used variables
  176. #
  177. proc reset_vars {} {
  178.     # test result counters
  179.     global failcnt
  180.     global passcnt
  181.     global testcnt
  182.     global xfailcnt
  183.     global xpasscnt
  184.     global untestedcnt
  185.     global unresolvedcnt
  186.     global unsupportedcnt
  187.     
  188.     # prms id number and test name variables
  189.     global prms_id
  190.     global test_name
  191.     
  192.     # reset all counters, prms_id and test_name 
  193.     set prms_id    0
  194.     set test_name    ""
  195.     
  196.     set failcnt    0
  197.     set passcnt    0
  198.     set testcnt    0
  199.     set xfailcnt    0
  200.     set xpasscnt    0
  201.     set untestedcnt    0
  202.     set unresolvedcnt    0
  203.     set unsupportedcnt    0
  204. }
  205.  
  206. #
  207. # log_summary -- print summary of all pass/fail counts. Calling this exits.
  208. #
  209. proc log_summary {} {
  210.     global tool
  211.     global sum_file
  212.     global exit_status
  213.     global failcnt
  214.     global passcnt
  215.     global testcnt
  216.     global xfailcnt
  217.     global xpasscnt
  218.     global untestedcnt
  219.     global unresolvedcnt
  220.     global unsupportedcnt
  221.     global mail_logs
  222.     global outdir
  223.     global tool.sum
  224.     global mailing_list
  225.     
  226.     if ![info exists totlcnt] then {
  227.     # total all the testcases reported
  228.     set totlcnt [expr $failcnt+$passcnt+$xfailcnt+$xpasscnt]
  229.     set totlcnt [expr $totlcnt+$untestedcnt+$unresolvedcnt+$unsupportedcnt]
  230.     }
  231.     
  232.     clone_output "\n\t\t=== $tool Summary ===\n"
  233.     
  234.     # compare reported number of testcases with expected number
  235.     if { $testcnt > 0 } then {
  236.     if { $testcnt>$totlcnt || $testcnt<$totlcnt } then {
  237.         if { $testcnt > $totlcnt } then {
  238.         set mismatch "unreported  [expr $testcnt-$totlcnt]"
  239.         }
  240.         if { $testcnt < $totlcnt } then {
  241.         set mismatch "misreported [expr $totlcnt-$testcnt]"
  242.         }
  243.     } else {
  244.         verbose "# of testcases run         $testcnt"
  245.     }
  246.     }
  247.     if [info exists mismatch] then {
  248.     clone_output "### ERROR: totals do not equal number of testcases run"
  249.     clone_output "### ERROR: # of testcases expected    $testcnt"
  250.     clone_output "### ERROR: # of testcases reported    $totlcnt"
  251.     clone_output "### ERROR: # of testcases $mismatch\n"
  252.     }
  253.     if { $passcnt > 0 } then {
  254.     clone_output "# of expected passes       $passcnt"
  255.     }
  256.     if { $xfailcnt > 0 } then {
  257.     clone_output "# of expected failures     $xfailcnt"
  258.     }
  259.     if { $xpasscnt > 0 } then {
  260.     clone_output "# of unexpected successes  $xpasscnt"
  261.     }
  262.     if { $failcnt > 0 } then {
  263.     clone_output "# of unexpected failures   $failcnt"
  264.     }
  265.     if { $unresolvedcnt > 0 } then {
  266.     clone_output "# of unresolved testcases  $unresolvedcnt"
  267.     }
  268.     if { $untestedcnt > 0 } then {
  269.     clone_output "# of untested testcases    $untestedcnt"
  270.     }
  271.     if { $unsupportedcnt > 0 } then {
  272.     clone_output "# of unsupported tests     $unsupportedcnt"
  273.     }
  274.     # extract version number
  275.     if {[info procs ${tool}_version] != ""} then {
  276.     if {[catch "${tool}_version" output]} {
  277.         warning "${tool}_version failed:\n$output"
  278.     }
  279.     }
  280.     close_logs
  281.     cleanup
  282.     if $mail_logs then {
  283.     mail_file $outdir/$tool.sum $mailing_list "Dejagnu Summary Log"
  284.     }
  285.     exit $exit_status
  286. }
  287.  
  288. #
  289. # cleanup -- close all open files,
  290. #         remove temp file and core files, and set exit status
  291. #
  292. proc cleanup {} {
  293.     global sum_file
  294.     global exit_status
  295.     global done_list
  296.     global base_dir
  297.     global subdir
  298.     
  299.     #catch "exec rm -f [glob xgdb core *.x *.o *_soc a.out]"
  300.     #catch "exec rm -f [glob -nocomplain $subdir/*.o $subdir/*.x $subdir/*_soc]"
  301. }
  302.  
  303. #
  304. # pass -- prints the default test passed message
  305. #
  306. proc pass { arg } {
  307.     global passcnt
  308.     global prms_id
  309.     global bug_id
  310.     global xfail_flag
  311.     global xfail_prms
  312.     global errcnt
  313.     global warncnt
  314.     
  315.     if $xfail_flag then {
  316.     if $xfail_prms!=0 {
  317.         set prms_id $xfail_prms
  318.     }
  319.     xpass $arg
  320.     set xfail_flag 0
  321.     if $xfail_prms!=0 {
  322.         set prms_id 0
  323.         set xfail_prms 0
  324.     }
  325.     return
  326.     }
  327.  
  328.     incr passcnt
  329.     
  330.     set format "PASS:\t$arg"
  331.  
  332.     # if we have too many warnings or errors, the output of the test can't be considered correct
  333.     if $warncnt>3 then {
  334.     unresolved $format
  335.     set warncnt 0
  336.     set errcnt  0
  337.     return
  338.     }
  339.     if $errcnt>1 then {
  340.     unresolved $format
  341.     set errcnt 0
  342.     set warncnt 0
  343.     return
  344.     }
  345.     
  346.     # reset these so they're ready for the next test case
  347.     set warncnt 0
  348.     set errcnt 0
  349.  
  350.     if $prms_id then {
  351.     set format [concat $format "\t(PRMS $prms_id)"]
  352.     }
  353.     if $bug_id then {
  354.     set format [concat $format "\t(BUG $bug_id)"]
  355.     }
  356.     
  357.     clone_output "$format"
  358. }
  359.  
  360. #
  361. # xpass -- print the the default test passed unlike expected message
  362. #
  363. proc xpass { arg } {
  364.     global xpasscnt
  365.     global prms_id
  366.     global bug_id
  367.     
  368.     incr xpasscnt
  369.  
  370.     set exit_status 1
  371.     
  372.     set format "XPASS:\t$arg"
  373.     if $prms_id then {
  374.     set format [concat $format "\t(PRMS $prms_id)"]
  375.     }
  376.     if $bug_id then {
  377.     set format [concat $format "\t(BUG $bug_id)"]
  378.     }
  379.     
  380.     clone_output "$format"
  381. }
  382.  
  383. #
  384. # xfail -- print the the default test failed like expected message
  385. #
  386. proc xfail { arg } {
  387.     global xfailcnt
  388.     global prms_id
  389.     global bug_id
  390.     
  391.     incr xfailcnt
  392.  
  393.     set exit_status 1
  394.     
  395.     set format "XFAIL:\t$arg"
  396.     if $prms_id then {
  397.     set format [concat $format "\t(PRMS $prms_id)"]
  398.     }
  399.     if $bug_id then {
  400.     
  401.     set format [concat $format "\t(BUG $bug_id)"]
  402.     }
  403.     
  404.     clone_output "$format"
  405. }
  406.  
  407. #
  408. # setup_xfail -- setup a flag to control whether a failure
  409. #                is expected or not.`
  410. #
  411. # Multiple target triplet patterns can be specified for targets
  412. # for which the test fails.  A decimal number can be specified,
  413. # which is the PRMS number.
  414. #
  415. proc setup_xfail { args } {
  416.     global xfail_flag
  417.     global xfail_prms
  418.     global decimal
  419.     
  420.     set argc [ llength $args ]
  421.     for { set i 0 } { $i < $argc } { incr i } {
  422.     set sub_arg [ lindex $args $i ]
  423.     # is a prms number. we assume this is a number with no characters
  424.     if [regexp "^\[0-9\]+$" $sub_arg] then { 
  425.         set xfail_prms $sub_arg
  426.         continue
  427.     }
  428.     if [istarget $sub_arg] then {
  429.         set xfail_flag 1
  430.         continue
  431.     }
  432.     }
  433. }
  434.  
  435. #
  436. # clear_xfail -- clear the xfail flag for a particular target.
  437. #
  438. proc clear_xfail { args } {
  439.     global xfail_flag
  440.     global xfail_prms
  441.     global decimal
  442.     
  443.     set argc [ llength $args ]
  444.     for { set i 0 } { $i < $argc } { incr i } {
  445.     set sub_arg [ lindex $args $i ]
  446.     case $sub_arg in {
  447.         "*-*-*" {            # is a configuration triplet
  448.         if [istarget $sub_arg] then {
  449.             set xfail_flag 0
  450.             set xfail_prms 0
  451.         }
  452.         continue
  453.         }
  454.     }
  455.     }
  456. }
  457.  
  458. #
  459. # fail -- prints the default test failed message
  460. #
  461. proc fail { arg } {
  462.     global failcnt
  463.     global prms_id
  464.     global bug_id
  465.     global exit_status
  466.     global xfail_flag
  467.     global xfail_prms
  468.     global errcnt
  469.     global warncnt
  470.  
  471.     if $xfail_flag then {
  472.     if $xfail_prms!=0 {
  473.         set prms_id $xfail_prms
  474.     }
  475.     xfail $arg
  476.     set xfail_flag 0
  477.     if $xfail_prms!=0 {
  478.         set prms_id 0
  479.         set xfail_prms 0
  480.     }
  481.     return
  482.     }
  483.     
  484.     incr failcnt
  485.  
  486.     set exit_status 1
  487.  
  488.     set format "FAIL:\t$arg"
  489.  
  490.     # if we have too many warnings or errors, the output of the test can't be considered correct
  491.     if $warncnt>3 then {
  492.     unresolved $format
  493.     set warncnt 0
  494.     set errcnt  0
  495.     return
  496.     }
  497.     if $errcnt>1 then {
  498.     unresolved $format
  499.     set errcnt  0
  500.     set warncnt 0
  501.     return
  502.     }
  503.     
  504.     # reset these so they're ready for the next test case
  505.     set warncnt 0
  506.     set errcnt 0
  507.  
  508.     if $prms_id then {
  509.     set format [concat $format "\t(PRMS $prms_id)"]
  510.     }
  511.     if $bug_id then {
  512.     set format [concat $format "\t(BUG $bug_id)"]
  513.     }
  514.  
  515.     clone_output "$format"
  516. }
  517.  
  518. #
  519. # warning -- prints a warning messages. These are warnings from the framework,
  520. #            not from the tools being tested.
  521. #
  522. proc warning { message } {
  523.     global verbose
  524.     global warncnt
  525.     
  526.     incr warncnt
  527.     clone_output "WARNING: $message"
  528.     if [info exists errorInfo] then {
  529.     unset errorInfo
  530.     }
  531. }
  532.  
  533. #
  534. # perror -- prints a error messages. These are errors from the framework,
  535. #          not from the tools being tested.
  536. #
  537. proc perror { message } {
  538.     global verbose
  539.     global errcnt
  540.     
  541.     incr errcnt
  542.     clone_output "ERROR: $message"
  543.     if [info exists errorInfo] then {
  544.     unset errorInfo
  545.     }
  546. }
  547.  
  548. #
  549. # untested -- For some reason this test case is untested.
  550. #
  551. proc untested { arg } {
  552.     global untestedcnt
  553.     global prms_id
  554.     global bug_id
  555.     global exit_status
  556.     global xfail_flag
  557.     global xfail_prms
  558.     
  559.     if $xfail_flag then {
  560.         if $xfail_prms!=0 {
  561.         set prms_id $xfail_prms
  562.     }
  563.         xfail $arg
  564.         set xfail_flag 0
  565.         if $xfail_prms!=0 {
  566.         set prms_id 0
  567.         set xfail_prms 0
  568.     }
  569.         return
  570.     }
  571.     
  572.     incr untestedcnt
  573.  
  574.     set exit_status 1
  575.     
  576.     set format "UNTESTED:\t$arg"
  577.     if $prms_id then {
  578.         set format [concat $format "\t(PRMS $prms_id)"]
  579.     }
  580.     if $bug_id then {
  581.         set format [concat $format "\t(BUG $bug_id)"]
  582.     }
  583.     
  584.     clone_output "$format"
  585. }
  586.  
  587. #
  588. # unresolved -- The test vcase has an unresolved outcome.
  589. #
  590. proc unresolved { arg } {
  591.     global unresolvedcnt
  592.     global prms_id
  593.     global bug_id
  594.     global exit_status
  595.     global xfail_flag
  596.     global xfail_prms
  597.     
  598.     if $xfail_flag then {
  599.         if $xfail_prms!=0 {
  600.         set prms_id $xfail_prms
  601.     }
  602.         xfail $arg
  603.         set xfail_flag 0
  604.         if $xfail_prms!=0 {
  605.         set prms_id 0
  606.         set xfail_prms 0
  607.     }
  608.         return
  609.     }
  610.     
  611.     incr unresolvedcnt
  612.  
  613.     set exit_status 1
  614.     
  615.     set format "UNRESOLVED:\t$arg"
  616.     if $prms_id then {
  617.         set format [concat $format "\t(PRMS $prms_id)"]
  618.     }
  619.     if $bug_id then {
  620.         set format [concat $format "\t(BUG $bug_id)"]
  621.     }
  622.     
  623.     clone_output "$format"
  624. }
  625.  
  626. #
  627. # unsupported -- The test case is unsupported. Usually this is used for a test
  628. #                that is missing OS support.
  629. #
  630. proc unsupported { arg } {
  631.     global unsupportedcnt
  632.     global prms_id
  633.     global bug_id
  634.     global exit_status
  635.     global xfail_flag
  636.     global xfail_prms
  637.  
  638.     if $xfail_flag then {
  639.         if $xfail_prms!=0 {
  640.         set prms_id $xfail_prms
  641.     }
  642.         xfail $arg
  643.         set xfail_flag 0
  644.         if $xfail_prms!=0 {
  645.         set prms_id 0
  646.         set xfail_prms 0
  647.     }
  648.         return
  649.     }
  650.     
  651.     incr unsupportedcnt
  652.  
  653.     set exit_status 1
  654.     
  655.     set format "UNSUPPORTED:\t$arg"
  656.     if $prms_id then {
  657.         set format [concat $format "\t(PRMS $prms_id)"]
  658.     }
  659.     if $bug_id then {
  660.         set format [concat $format "\t(BUG $bug_id)"]
  661.     }
  662.     
  663.     clone_output "$format"
  664. }
  665.  
  666. #
  667. # exp_continue -- create this if it doesn't exist. For compatablity
  668. #                 with old versions.
  669. #
  670. global argv0
  671. if ![info exists argv0] then {
  672.     proc exp_continue { } {
  673.     continue -expect
  674.     }
  675. }
  676.