home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tk3.3b1 / tests / defs < prev    next >
Encoding:
Text File  |  1993-07-08  |  2.1 KB  |  69 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.  
  9. # Some of the tests don't work on some system configurations due to
  10. # configuration quirks, not due to Tk problems;  in order to prevent
  11. # false alarms, these tests are only run in the master source directory
  12. # at Berkeley.  The presence of a file "Berkeley" in this directory is
  13. # used to indicate that these tests should be run.
  14.  
  15. set atBerkeley [file exists Berkeley]
  16.  
  17. proc print_verbose {test_name test_description contents_of_test answer} {
  18.     puts stdout "\n"
  19.     puts stdout "==== $test_name $test_description"
  20.     puts stdout "==== Contents of test case:"
  21.     puts stdout "$contents_of_test"
  22.     puts stdout "==== Result was:"
  23.     puts stdout "$answer"
  24. }
  25.  
  26. proc test {test_name test_description contents_of_test passing_results} {
  27.     global VERBOSE
  28.     global TESTS
  29.     if {[string compare $TESTS ""] != 0} then {
  30.     set ok 0
  31.     foreach test $TESTS {
  32.         if [string match $test $test_name] then {
  33.         set ok 1
  34.         break
  35.         }
  36.         }
  37.     if !$ok then return
  38.     }
  39.     set answer [uplevel $contents_of_test]
  40.     if {[string compare $answer $passing_results] == 0} then { 
  41.     if $VERBOSE then {
  42.         print_verbose $test_name $test_description $contents_of_test $answer
  43.         puts stdout "++++ $test_name PASSED"
  44.     }
  45.     } else { 
  46.     print_verbose $test_name $test_description $contents_of_test $answer 
  47.     puts stdout "---- Result should have been:"
  48.     puts stdout "$passing_results"
  49.     puts stdout "---- $test_name FAILED" 
  50.     }
  51. }
  52.  
  53. proc dotests {file args} {
  54.     global TESTS
  55.     set savedTests $TESTS
  56.     set TESTS $args
  57.     source $file
  58.     set TESTS $savedTests
  59. }
  60.  
  61. # If the main window isn't already mapped (e.g. because the tests are
  62. # being run automatically) , specify a precise size for it so that the
  63. # user won't have to position it manually.
  64.  
  65. if {![winfo ismapped .]} {
  66.     wm geometry . +0+0
  67.     update
  68. }
  69.