home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / tests / testlib.tcl < prev    next >
Encoding:
Text File  |  1993-10-26  |  3.7 KB  |  111 lines  |  [TEXT/MPS ]
  1. #
  2. # testlib.tcl --
  3. #
  4. # Test support routines.  Some of these are based on routines provided with
  5. # standard Tcl.
  6. #------------------------------------------------------------------------------
  7. # Set the global variable TEST_ERROR_INFO to display errorInfo when a test
  8. # fails.
  9. #------------------------------------------------------------------------------
  10. # Copyright 1992-1993 Karl Lehenbauer and Mark Diekhans.
  11. #
  12. # Permission to use, copy, modify, and distribute this software and its
  13. # documentation for any purpose and without fee is hereby granted, provided
  14. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  15. # Mark Diekhans make no representations about the suitability of this
  16. # software for any purpose.  It is provided "as is" without express or
  17. # implied warranty.
  18. #------------------------------------------------------------------------------
  19. # $Id: testlib.tcl,v 2.3 1993/08/13 06:32:33 markd Exp $
  20. #------------------------------------------------------------------------------
  21. #
  22.  
  23. # Save the unknown command in a variable SAVED_UNKNOWN.  To get it back, eval
  24. # that variable.  Don't do this more than once.
  25.  
  26. global SAVED_UNKNOWN
  27.  
  28. if {([info command unknown] == "") && ![info exists SAVED_UNKNOWN]} {
  29.     error "can't find either unknown or SAVED_UNKNOWN"
  30. }
  31. if {[info command unknown] != ""} {
  32.     set SAVED_UNKNOWN "proc unknown "
  33.     append SAVED_UNKNOWN "\{[info args unknown]\} "
  34.     append SAVED_UNKNOWN "\{[info body unknown]\}"
  35.     rename unknown {}
  36. }
  37.  
  38. #
  39. # Output a test error.
  40. #
  41. proc OutTestError {test_name test_description contents_of_test
  42.                    passing_int_result passing_result int_result result} {
  43.     global TEST_ERROR_INFO errorInfo
  44.     set int(0) TCL_OK
  45.     set int(1) TCL_ERROR
  46.     set int(2) TCL_RETURN
  47.     set int(3) TCL_BREAK
  48.     set int(4) TCL_CONTINUE
  49.  
  50.     puts stdout "==== $test_name $test_description"
  51.     puts stdout "==== Contents of test case:"
  52.     puts stdout "$contents_of_test"
  53.     puts stdout "==== Result was: $int($int_result)"
  54.     puts stdout "$result"
  55.     puts stdout "---- Result should have been: $int($passing_int_result)"
  56.     puts stdout "$passing_result"
  57.     puts stdout "---- $test_name FAILED" 
  58.     if {[info exists TEST_ERROR_INFO] && [info exists errorInfo]} {
  59.         puts stdout $errorInfo
  60.         puts stdout "---------------------------------------------------"
  61.     }
  62. }
  63.  
  64. #
  65. # Routine to execute tests and compare to expected results.
  66. #
  67. proc Test {test_name test_description contents_of_test passing_int_result
  68.            passing_result} {
  69.     set int_result [catch {uplevel $contents_of_test} result]
  70.  
  71.     if {($int_result != $passing_int_result) ||
  72.         ($result != $passing_result)} {
  73.         OutTestError $test_name $test_description $contents_of_test \
  74.                      $passing_int_result $passing_result $int_result $result
  75.     }
  76. }
  77.  
  78. #
  79. # Compare result against case-insensitive regular expression.
  80. #
  81.  
  82. proc TestReg {test_name test_description contents_of_test passing_int_result
  83.               passing_result} {
  84.     set int_result [catch {uplevel $contents_of_test} result]
  85.  
  86.     if {($int_result != $passing_int_result) ||
  87.         ![regexp -nocase $passing_result $result]} {
  88.         OutTestError $test_name $test_description $contents_of_test \
  89.                      $passing_int_result $passing_result $int_result $result
  90.     }
  91. }
  92.  
  93. proc dotests {file args} {
  94.     global TESTS
  95.     set savedTests $TESTS
  96.     set TESTS $args
  97.     source $file
  98.     set TESTS $savedTests
  99. }
  100.  
  101. # Genenerate a unique file record that can be verified.  The record
  102. # grows quite large to test the dynamic buffering in the file I/O.
  103.  
  104. proc GenRec {id} {
  105.     return [format "Key:%04d {This is a test of file I/O (%d)} KeyX:%04d %s" \
  106.                     $id $id $id [replicate :@@@@@@@@: $id]]
  107. }
  108.  
  109.  
  110.  
  111.