home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / tcl / tclsrc / tests / defs < prev    next >
Text File  |  1995-05-19  |  3KB  |  113 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.4 95/05/19 10:02:04
  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. # If there is no "memory" command (because memory debugging isn't
  41. # enabled), generate a dummy command that does nothing.
  42.  
  43. if {[info commands memory] == ""} {
  44.     proc memory args {}
  45. }
  46.  
  47. proc print_verbose {test_name test_description contents_of_test code answer} {
  48.     puts stdout "\n"
  49.     puts stdout "==== $test_name $test_description"
  50.     puts stdout "==== Contents of test case:"
  51.     puts stdout "$contents_of_test"
  52.     if {$code != 0} {
  53.     if {$code == 1} {
  54.         puts stdout "==== Test generated error:"
  55.         puts stdout $answer
  56.     } elseif {$code == 2} {
  57.         puts stdout "==== Test generated return exception;  result was:"
  58.         puts stdout $answer
  59.     } elseif {$code == 3} {
  60.         puts stdout "==== Test generated break exception"
  61.     } elseif {$code == 4} {
  62.         puts stdout "==== Test generated continue exception"
  63.     } else {
  64.         puts stdout "==== Test generated exception $code;  message was:"
  65.         puts stdout $answer
  66.     }
  67.     } else {
  68.     puts stdout "==== Result was:"
  69.     puts stdout "$answer"
  70.     }
  71. }
  72.  
  73. proc test {test_name test_description contents_of_test passing_results} {
  74.     global VERBOSE
  75.     global TESTS
  76.     if {[string compare $TESTS ""] != 0} then {
  77.     set ok 0
  78.     foreach test $TESTS {
  79.         if [string match $test $test_name] then {
  80.         set ok 1
  81.         break
  82.         }
  83.         }
  84.     if !$ok then return
  85.     }
  86.     memory tag $test_name
  87.     set code [catch {uplevel $contents_of_test} answer]
  88.     if {$code != 0} {
  89.     print_verbose $test_name $test_description $contents_of_test \
  90.         $code $answer
  91.     } elseif {[string compare $answer $passing_results] == 0} then { 
  92.     if $VERBOSE then {
  93.         print_verbose $test_name $test_description $contents_of_test \
  94.             $code $answer
  95.         puts stdout "++++ $test_name PASSED"
  96.     }
  97.     } else {
  98.     print_verbose $test_name $test_description $contents_of_test $code \
  99.         $answer 
  100.     puts stdout "---- Result should have been:"
  101.     puts stdout "$passing_results"
  102.     puts stdout "---- $test_name FAILED" 
  103.     }
  104. }
  105.  
  106. proc dotests {file args} {
  107.     global TESTS
  108.     set savedTests $TESTS
  109.     set TESTS $args
  110.     source $file
  111.     set TESTS $savedTests
  112. }
  113.