home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume25 / tcl / part01 / tcl6.1 / tests / defs < prev    next >
Encoding:
Text File  |  1991-11-14  |  1.8 KB  |  65 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. proc print_verbose {test_name test_description contents_of_test answer} {
  23.     puts stdout "\n"
  24.     puts stdout "==== $test_name $test_description"
  25.     puts stdout "==== Contents of test case:"
  26.     puts stdout "$contents_of_test"
  27.     puts stdout "==== Result was:"
  28.     puts stdout "$answer"
  29. }
  30.  
  31. proc test {test_name test_description contents_of_test passing_results} {
  32.     global VERBOSE
  33.     global TESTS
  34.     if {[string compare $TESTS ""] != 0} then {
  35.     set ok 0
  36.     foreach test $TESTS {
  37.         if [string match $test $test_name] then {
  38.         set ok 1
  39.         break
  40.         }
  41.         }
  42.     if !$ok then return
  43.     }
  44.     set answer [uplevel $contents_of_test]
  45.     if {[string compare $answer $passing_results] == 0} then { 
  46.     if $VERBOSE then {
  47.         print_verbose $test_name $test_description $contents_of_test $answer
  48.         puts stdout "++++ $test_name PASSED"
  49.     }
  50.     } else { 
  51.     print_verbose $test_name $test_description $contents_of_test $answer 
  52.     puts stdout "---- Result should have been:"
  53.     puts stdout "$passing_results"
  54.     puts stdout "---- $test_name FAILED" 
  55.     }
  56. }
  57.  
  58. proc dotests {file args} {
  59.     global TESTS
  60.     set savedTests $TESTS
  61.     set TESTS $args
  62.     source $file
  63.     set TESTS $savedTests
  64. }
  65.