Index: openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl,v diff -u -r1.4 -r1.5 --- openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 2 Apr 2003 16:06:44 -0000 1.4 +++ openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 4 Apr 2003 08:04:32 -0000 1.5 @@ -731,10 +731,39 @@ } } -# -# Set the valid testcase categories list, and testcase/component lists. -# -nsv_set aa_test cases {} -nsv_set aa_test components {} -nsv_set aa_test init_classes {} -nsv_set aa_test categories {config db script web} +ad_proc aa_run_with_teardown { + {-test_code:required} + {-teardown_code:required} +} { + Execute code in test_code and guarantee that code in + teardown_code will be executed even if error is thrown. Will catch + errors in teardown_code as well and provide stack traces for both code blocks. + + @param test_code Tcl code that sets up the test case and executes tests + @param teardown_code Tcl code that tears down database data etc. that needs to execute + after testing even if error is thrown. + + @author Peter Marklund +} { + # Testing + set setup_error_p [catch $test_code setup_error] + global errorInfo + set setup_error_stack $errorInfo + + # Teardown + set teardown_error_p [catch $teardown_code teardown_error] + global errorInfo + set teardown_error_stack $errorInfo + + # Provide meaningful error messages and stack traces + set error_text "" + if { $setup_error_p } { + append error_text "Setup failed with error $setup_error\n\n$setup_error_stack" + } + if { $teardown_error_p } { + append error_text "\n\nTeardown failed with error $teardown_error\n\n$teardown_error_stack" + } + if { ![empty_string_p $error_text] } { + error $error_text + } +}