home *** CD-ROM | disk | FTP | other *** search
/ Stone Design / Stone Design.iso / Stone_Friends / Wave / WavesWorld / Source / Libraries / tcl7.4b3 / tests / defs < prev    next >
Encoding:
Text File  |  1994-12-17  |  3.2 KB  |  105 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. # Copyright (c) 1990-1994 The Regents of the University of California.
  7. # Copyright (c) 1994 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. #
  12. # @(#) defs 1.3 94/12/17 16:19:48
  13.  
  14. if ![info exists VERBOSE] {
  15.     set VERBOSE 0
  16. }
  17. if ![info exists TESTS] {
  18.     set TESTS {}
  19. }
  20.  
  21. # If tests are being run as root, issue a warning message and set a
  22. # variable to prevent some tests from running at all.
  23.  
  24. set user {}
  25. catch {set user [exec whoami]}
  26. if {$user == "root"} {
  27.     puts stdout "Warning: you're executing as root.  I'll have to"
  28.     puts stdout "skip some of the tests, since they'll fail as root."
  29. }
  30.  
  31. # Some of the tests don't work on some system configurations due to
  32. # differences in word length, file system configuration, etc.  In order
  33. # to prevent false alarms, these tests are generally only run in the
  34. # master development directory for Tcl.  The presence of a file
  35. # "doAllTests" in this directory is used to indicate that the non-portable
  36. # tests should be run.
  37.  
  38. set doNonPortableTests [file exists doAllTests]
  39.  
  40. proc print_verbose {test_name test_description contents_of_test code answer} {
  41.     puts stdout "\n"
  42.     puts stdout "==== $test_name $test_description"
  43.     puts stdout "==== Contents of test case:"
  44.     puts stdout "$contents_of_test"
  45.     if {$code != 0} {
  46.     if {$code == 1} {
  47.         puts stdout "==== Test generated error:"
  48.         puts stdout $answer
  49.     } elseif {$code == 2} {
  50.         puts stdout "==== Test generated return exception;  result was:"
  51.         puts stdout $answer
  52.     } elseif {$code == 3} {
  53.         puts stdout "==== Test generated break exception"
  54.     } elseif {$code == 4} {
  55.         puts stdout "==== Test generated continue exception"
  56.     } else {
  57.         puts stdout "==== Test generated exception $code;  message was:"
  58.         puts stdout $answer
  59.     }
  60.     } else {
  61.     puts stdout "==== Result was:"
  62.     puts stdout "$answer"
  63.     }
  64. }
  65.  
  66. proc test {test_name test_description contents_of_test passing_results} {
  67.     global VERBOSE
  68.     global TESTS
  69.     if {[string compare $TESTS ""] != 0} then {
  70.     set ok 0
  71.     foreach test $TESTS {
  72.         if [string match $test $test_name] then {
  73.         set ok 1
  74.         break
  75.         }
  76.         }
  77.     if !$ok then return
  78.     }
  79.     set code [catch {uplevel $contents_of_test} answer]
  80.     if {$code != 0} {
  81.     print_verbose $test_name $test_description $contents_of_test \
  82.         $code $answer
  83.     } elseif {[string compare $answer $passing_results] == 0} then { 
  84.     if $VERBOSE then {
  85.         print_verbose $test_name $test_description $contents_of_test \
  86.             $code $answer
  87.         puts stdout "++++ $test_name PASSED"
  88.     }
  89.     } else {
  90.     print_verbose $test_name $test_description $contents_of_test $code \
  91.         $answer 
  92.     puts stdout "---- Result should have been:"
  93.     puts stdout "$passing_results"
  94.     puts stdout "---- $test_name FAILED" 
  95.     }
  96. }
  97.  
  98. proc dotests {file args} {
  99.     global TESTS
  100.     set savedTests $TESTS
  101.     set TESTS $args
  102.     source $file
  103.     set TESTS $savedTests
  104. }
  105.