home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcl2-73c.zip / tcl7.3 / tests / defs < prev    next >
Text File  |  1994-03-12  |  3KB  |  95 lines
  1. # This file contains support code for the Tcl test suite.  It is
  2. # normally sourced by the individual files in the test suite before
  3. # they run their tests.  This improved approach to testing was designed
  4. # and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
  5.  
  6. set VERBOSE 0
  7. set TESTS {}
  8. set auto_noexec 1
  9. set auto_noload 1
  10. catch {rename unknown ""}
  11.  
  12. # If tests are being run as root, issue a warning message and set a
  13. # variable to prevent some tests from running at all.
  14.  
  15. set user {}
  16. catch {set user [exec whoami]}
  17. if {$user == "root"} {
  18.     puts stdout "Warning: you're executing as root.  I'll have to"
  19.     puts stdout "skip some of the tests, since they'll fail as root."
  20. }
  21.  
  22. # Some of the tests don't work on some system configurations due to
  23. # configuration quirks, not due to Tcl problems;  in order to prevent
  24. # false alarms, these tests are only run in the master source directory
  25. # at Berkeley.  The presence of a file "Berkeley" in this directory is
  26. # used to indicate that these tests should be run.
  27.  
  28. set atBerkeley [file exists Berkeley]
  29.  
  30. proc print_verbose {test_name test_description contents_of_test code answer} {
  31.     puts stdout "\n"
  32.     puts stdout "==== $test_name $test_description"
  33.     puts stdout "==== Contents of test case:"
  34.     puts stdout "$contents_of_test"
  35.     if {$code != 0} {
  36.     if {$code == 1} {
  37.         puts stdout "==== Test generated error:"
  38.         puts stdout $answer
  39.     } elseif {$code == 2} {
  40.         puts stdout "==== Test generated return exception;  result was:"
  41.         puts stdout $answer
  42.     } elseif {$code == 3} {
  43.         puts stdout "==== Test generated break exception"
  44.     } elseif {$code == 4} {
  45.         puts stdout "==== Test generated continue exception"
  46.     } else {
  47.         puts stdout "==== Test generated exception $code;  message was:"
  48.         puts stdout $answer
  49.     }
  50.     } else {
  51.     puts stdout "==== Result was:"
  52.     puts stdout "$answer"
  53.     }
  54. }
  55.  
  56. proc test {test_name test_description contents_of_test passing_results} {
  57.     global VERBOSE
  58.     global TESTS
  59.     if {[string compare $TESTS ""] != 0} then {
  60.     set ok 0
  61.     foreach test $TESTS {
  62.         if [string match $test $test_name] then {
  63.         set ok 1
  64.         break
  65.         }
  66.         }
  67.     if !$ok then return
  68.     }
  69.     set code [catch {uplevel $contents_of_test} answer]
  70.     if {$code != 0} {
  71.     print_verbose $test_name $test_description $contents_of_test \
  72.         $code $answer
  73.     } elseif {[string compare $answer $passing_results] == 0} then { 
  74.     if $VERBOSE then {
  75.         print_verbose $test_name $test_description $contents_of_test \
  76.             $code $answer
  77.         puts stdout "++++ $test_name PASSED"
  78.     }
  79.     } else {
  80.     print_verbose $test_name $test_description $contents_of_test $code \
  81.         $answer 
  82.     puts stdout "---- Result should have been:"
  83.     puts stdout "$passing_results"
  84.     puts stdout "---- $test_name FAILED" 
  85.     }
  86. }
  87.  
  88. proc dotests {file args} {
  89.     global TESTS
  90.     set savedTests $TESTS
  91.     set TESTS $args
  92.     source $file
  93.     set TESTS $savedTests
  94. }
  95.