home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / src / X11 / tclMotif-1.4 / tests / defs < prev    next >
Encoding:
Text File  |  1995-06-29  |  2.2 KB  |  74 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 INTERACTIVE 0
  8. set TESTS {}
  9. set auto_noexec 1
  10. set auto_noload 1
  11. # catch {rename unknown ""}
  12.  
  13. # If tests are being run as root, issue a warning message and set a
  14. # variable to prevent some tests from running at all.
  15.  
  16. set user {}
  17. catch {set user [exec whoami]}
  18. if {$user == "root"} {
  19.     puts stdout "Warning: you're executing as root.  I'll have to"
  20.     puts stdout "skip some of the tests, since they'll fail as root."
  21. }
  22.  
  23. # Some of the tests don't work on some system configurations due to
  24. # configuration quirks, not due to Tcl problems;  in order to prevent
  25. # false alarms, these tests are only run in the master source directory
  26. # at Berkeley.  The presence of a file "Berkeley" in this directory is
  27. # used to indicate that these tests should be run.
  28.  
  29. set atBerkeley [file exists Berkeley]
  30.  
  31. proc print_verbose {test_name test_description contents_of_test answer} {
  32.     puts stdout "\n"
  33.     puts stdout "==== $test_name $test_description"
  34.     puts stdout "==== Contents of test case:"
  35.     puts stdout "$contents_of_test"
  36.     puts stdout "==== Result was:"
  37.     puts stdout "$answer"
  38. }
  39.  
  40. proc test {test_name test_description contents_of_test passing_results} {
  41.     global VERBOSE
  42.     global TESTS
  43.     if {[string compare $TESTS ""] != 0} then {
  44.     set ok 0
  45.     foreach test $TESTS {
  46.         if [string match $test $test_name] then {
  47.         set ok 1
  48.         break
  49.         }
  50.         }
  51.     if !$ok then return
  52.     }
  53.     set answer [uplevel $contents_of_test]
  54.     if {[string compare $answer $passing_results] == 0} then { 
  55.     if $VERBOSE then {
  56.         print_verbose $test_name $test_description $contents_of_test $answer
  57.         puts stdout "++++ $test_name PASSED"
  58.     }
  59.     } else { 
  60.     print_verbose $test_name $test_description $contents_of_test $answer 
  61.     puts stdout "---- Result should have been:"
  62.     puts stdout "$passing_results"
  63.     puts stdout "---- $test_name FAILED" 
  64.     }
  65. }
  66.  
  67. proc dotests {file args} {
  68.     global TESTS
  69.     set savedTests $TESTS
  70.     set TESTS $args
  71.     source $file
  72.     set TESTS $savedTests
  73. }
  74.