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.11 -r1.12 --- openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 2 Sep 2003 13:03:07 -0000 1.11 +++ openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 5 Sep 2003 12:50:24 -0000 1.12 @@ -8,25 +8,25 @@ ad_library { - Procs to support the acs-automated-testing package. + Procs to support the acs-automated-testing package. - NOTE: There's a hack in packages/acs-bootstrap-installer/bootstrap.tcl to load - this file on server startup before other packages' -procs files. - - @author Peter Harper (peter.harper@open-msg.com) - @creation-date 21 June 2001 - @cvs-id $Id$ + NOTE: There's a hack in packages/acs-bootstrap-installer/bootstrap.tcl to load + this file on server startup before other packages' -procs files. + + @author Peter Harper (peter.harper@open-msg.com) + @creation-date 21 June 2001 + @cvs-id $Id$ } # LARS: We do this here, because if we do it in the -init file, then we cannot register # test cases in -procs files of packages. if { ![nsv_exists aa_test cases] } { - 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} + 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 -public aa_stub { proc_name new_body @@ -113,7 +113,7 @@ # set package_root [file join [acs_root_dir] packages] set package_rel [string replace [info script] \ - 0 [string length $package_root]] + 0 [string length $package_root]] set package_key [lindex [file split $package_rel] 0] # # First, search the current list of init_classes. If an old version already @@ -125,11 +125,11 @@ if {[lindex $init_class 0] == $init_class_id && [lindex $init_class 1] == $package_key} { nsv_set aa_test init_classes [lreplace [nsv_get aa_test init_classes] \ - $lpos $lpos \ - [list $init_class_id $package_key \ - $init_class_desc \ - [info script] \ - $constructor $destructor]] + $lpos $lpos \ + [list $init_class_id $package_key \ + $init_class_desc \ + [info script] \ + $constructor $destructor]] set found_pos $lpos break } @@ -182,7 +182,7 @@ # set package_root [file join [acs_root_dir] packages] set package_rel [string replace [info script] \ - 0 [string length $package_root]] + 0 [string length $package_root]] set package_key [lindex [file split $package_rel] 0] # # First, search the current list of components. If an old version already @@ -194,11 +194,11 @@ if {[lindex $component 0] == $component_id && [lindex $component 1] == $package_key} { nsv_set aa_test components [lreplace [nsv_get aa_test components] \ - $lpos $lpos \ - [list $component_id $package_key \ - $component_desc \ - [info script] \ - $body]] + $lpos $lpos \ + [list $component_id $package_key \ + $component_desc \ + [info script] \ + $body]] set found_pos $lpos break } @@ -210,12 +210,12 @@ # if {$found_pos == -1} { nsv_lappend aa_test components [list $component_id $package_key \ - $component_desc \ - [info script] \ - $body] + $component_desc \ + [info script] \ + $body] } -# set munged_body [subst {uplevel 1 {$body}}] + # set munged_body [subst {uplevel 1 {$body}}] ad_proc _${package_key}__c_$component_id {} $body } @@ -290,7 +290,7 @@ # set package_root [file join [acs_root_dir] packages] set package_rel [string replace [info script] \ - 0 [string length $package_root]] + 0 [string length $package_root]] set package_key [lindex [file split $package_rel] 0] # @@ -339,9 +339,9 @@ if {[lindex $case 0] == $testcase_id && [lindex $case 3] == $package_key} { nsv_set aa_test cases [lreplace [nsv_get aa_test cases] $lpos $lpos \ - [list $testcase_id $testcase_desc \ - [info script] $package_key \ - $cats $init_classes $on_error $args]] + [list $testcase_id $testcase_desc \ + [info script] $package_key \ + $cats $init_classes $on_error $args]] set found_pos $lpos break } @@ -353,8 +353,8 @@ # if {$found_pos == -1} { nsv_lappend aa_test cases [list $testcase_id $testcase_desc \ - [info script] $package_key \ - $cats $init_classes $on_error $args] + [info script] $package_key \ + $cats $init_classes $on_error $args] } if {[llength $init_classes] == 0} { @@ -444,7 +444,7 @@ set categories [lindex $testcase 4] set init_classes [lindex $testcase 5] if {($by_package_key == "" || ($by_package_key == $package_key)) && \ - ($by_category == "" || ([lsearch $categories $by_category] != -1))} { + ($by_category == "" || ([lsearch $categories $by_category] != -1))} { lappend testcase_ids $testcase_id foreach init_class $init_classes { set classes([list $package_key $init_class]) 1 @@ -579,25 +579,21 @@ } { Tests that the affirm_actual is equal to affirm_value.

Call this function within a testcase, stub or component. + + @return True if the affirmation passed, false otherwise. + @author Peter Harper @creation-date 24 July 2001 } { global aa_testcase_id global aa_package_key - if { [aa_in_rollback_block_p] } { - aa_add_rollback_test [list aa_equals $affirm_name $affirm_actual $affirm_value] - return - } - - if {$affirm_actual != $affirm_value} { - aa_log_result "fail" \ - "$affirm_name \ - Affirm FAILED, actual = \"$affirm_actual\", expected = \"$affirm_value\"" + if { [string equal $affirm_actual $affirm_value] } { + aa_log_result "pass" "$affirm_name Affirm PASSED, actual = \"$affirm_actual\"" + return 1 } else { - aa_log_result "pass" \ - "$affirm_name \ - Affirm PASSED, actual = \"$affirm_actual\"" + aa_log_result "fail" "$affirm_name Affirm FAILED, actual = \"$affirm_actual\", expected = \"$affirm_value\"" + return 0 } } @@ -607,26 +603,22 @@ } { Tests that affirm_expr is true.

Call this function within a testcase, stub or component. + + @return True if the affirmation passed, false otherwise. + @author Peter Harper @creation-date 24 July 2001 } { global aa_testcase_id global aa_package_key - - if { [aa_in_rollback_block_p] } { - aa_add_rollback_test [list aa_true $affirm_name $affirm_expr] - return - } - + set result [uplevel 1 [list expr $affirm_expr]] - if {$result} { - aa_log_result "pass" \ - "$affirm_name \ - Affirm PASSED, \"$affirm_expr\" true" + if { $result } { + aa_log_result "pass" "$affirm_name Affirm PASSED, \"$affirm_expr\" true" + return 1 } else { - aa_log_result "fail" \ - "$affirm_name \ - Affirm FAILED, \"$affirm_expr\" false" + aa_log_result "fail" "$affirm_name Affirm FAILED, \"$affirm_expr\" false" + return 0 } } @@ -636,26 +628,22 @@ } { Tests that affirm_expr is false.
Call this function within a testcase, stub or component. + + @return True if the affirmation passed, false otherwise. + @author Peter Harper @creation-date 24 July 2001 } { global aa_testcase_id global aa_package_key - if { [aa_in_rollback_block_p] } { - aa_add_rollback_test [list aa_false $affirm_name $affirm_expr] - return - } - set result [uplevel 1 [list expr $affirm_expr]] if {!$result} { - aa_log_result "pass" \ - "$affirm_name \ - Affirm PASSED, \"$affirm_expr\" false" + aa_log_result "pass" "$affirm_name Affirm PASSED, \"$affirm_expr\" false" + return 1 } else { - aa_log_result "fail" \ - "$affirm_name \ - Affirm FAILED, \"$affirm_expr\" true" + aa_log_result "fail" "$affirm_name Affirm FAILED, \"$affirm_expr\" true" + return 0 } } @@ -697,8 +685,8 @@ @creation-date 24 July 2001 } { if { [aa_in_rollback_block_p] } { - aa_add_rollback_test [list aa_log_result $test_result $test_notes] - return + aa_add_rollback_test [list aa_log_result $test_result $test_notes] + return } global aa_testcase_id @@ -716,7 +704,7 @@ # if {$aa_in_init_class != ""} { lappend aa_init_class_logs($aa_in_init_class) \ - [list $test_result $test_notes] + [list $test_result $test_notes] return } @@ -733,7 +721,7 @@ } # Notes in database can only hold so many characters if { [string length $test_notes] > 2000 } { - set test_notes "[string range $test_notes 0 1996]..." + set test_notes "[string range $test_notes 0 1996]..." } db_dml test_result_insert {} @@ -758,29 +746,29 @@ db_dml testcase_result_insert { insert into aa_test_final_results - (testcase_id, package_key, timestamp, passes, fails) + (testcase_id, package_key, timestamp, passes, fails) values (:aa_testcase_id, :aa_package_key, sysdate, :test_passes, :test_fails) } } ad_proc aa_run_with_teardown { - {-test_code:required} - {-teardown_code ""} - -rollback:boolean + {-test_code:required} + {-teardown_code ""} + -rollback:boolean } { - 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. + 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. - @param rollback If specified, any db transactions in test_code will be rolled back. + @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. + @param rollback If specified, any db transactions in test_code will be rolled back. - @author Peter Marklund + @author Peter Marklund } { - if { $rollback_p } { - set test_code " + if { $rollback_p } { + set test_code " db_transaction { aa_start_rollback_block @@ -800,90 +788,90 @@ aa_execute_rollback_tests " - } + } - # Testing - set setup_error_p [catch {uplevel $test_code} setup_error] + # Testing + set setup_error_p [catch {uplevel $test_code} setup_error] + global errorInfo + set setup_error_stack $errorInfo + + # Teardown + set teardown_error_p 0 + if { ![empty_string_p $teardown_code] } { + set teardown_error_p [catch {uplevel $teardown_code} teardown_error] global errorInfo - set setup_error_stack $errorInfo + set teardown_error_stack $errorInfo + } - # Teardown - set teardown_error_p 0 - if { ![empty_string_p $teardown_code] } { - set teardown_error_p [catch {uplevel $teardown_code} teardown_error] - global errorInfo - set teardown_error_stack $errorInfo - } - - # Provide complete error message and stack trace - 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 - } + # Provide complete error message and stack trace + 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 + } } ad_proc -private aa_start_rollback_block {} { - Start a block of code that is to be rolled back in the db + Start a block of code that is to be rolled back in the db - @author Peter Marklund + @author Peter Marklund } { - global aa_in_rollback_block_p - set aa_in_rollback_block_p 1 + global aa_in_rollback_block_p + set aa_in_rollback_block_p 1 } ad_proc -private aa_end_rollback_block {} { - End a block of code that is to be rolled back in the db + End a block of code that is to be rolled back in the db - @author Peter Marklund + @author Peter Marklund } { - global aa_in_rollback_block_p - set aa_in_rollback_block_p 0 + global aa_in_rollback_block_p + set aa_in_rollback_block_p 0 } ad_proc -private aa_in_rollback_block_p {} { - Return 1 if we are in a block of code that is to be rolled back in the db - and 0 otherwise. + Return 1 if we are in a block of code that is to be rolled back in the db + and 0 otherwise. - @author Peter Marklund + @author Peter Marklund } { - global aa_in_rollback_block_p - if { [info exists aa_in_rollback_block_p] } { - return $aa_in_rollback_block_p - } else { - return 0 - } + global aa_in_rollback_block_p + if { [info exists aa_in_rollback_block_p] } { + return $aa_in_rollback_block_p + } else { + return 0 + } } ad_proc -private aa_add_rollback_test {args} { - Add a test statement that is to be executed after a rollback block. - If it were to be executed during the rollback block it would be - rolled back and this is what we want to avoid. + Add a test statement that is to be executed after a rollback block. + If it were to be executed during the rollback block it would be + rolled back and this is what we want to avoid. - @author Peter Marklund + @author Peter Marklund } { - global aa_rollback_test_statements + global aa_rollback_test_statements - lappend aa_rollback_test_statements $args + lappend aa_rollback_test_statements $args } ad_proc -private aa_execute_rollback_tests {} { - Execute all test statements from a rollback block. + Execute all test statements from a rollback block. - @author Peter Marklund + @author Peter Marklund } { - global aa_rollback_test_statements + global aa_rollback_test_statements - if { [info exists aa_rollback_test_statements] } { - foreach test_statement $aa_rollback_test_statements { - eval [join $test_statement " "] - } + if { [info exists aa_rollback_test_statements] } { + foreach test_statement $aa_rollback_test_statements { + eval [join $test_statement " "] } + } - unset aa_rollback_test_statements + unset aa_rollback_test_statements }