- Either call this function from within a testcase for a testcase specific - stub, or outside a testcase for a file-wide stub. + Stubs a function. Provide the procedure name and the new body code. +
+ Either call this function from within a testcase for a testcase specific + stub, or outside a testcase for a file-wide stub. - @author Peter Harper - @creation-date 24 July 2001 + @author Peter Harper + @creation-date 24 July 2001 } { - global aa_stub_sequence - global aa_stub_names - global aa_testcase_id + global aa_stub_sequence + global aa_stub_names + global aa_testcase_id - if {[info exists aa_testcase_id]} { - # - # Runtime testcase stub. - # If a stub for this procedure hasn't already been defined, take a copy - # of the original procedure and add it to the aa_stub_names list. - # - if {[lsearch -exact $aa_stub_names $proc_name] == -1} { - lappend aa_stub_names $proc_name - proc ${proc_name}_unstubbed [info args $proc_name] [info body $proc_name] - } - set aa_stub_sequence($proc_name) 1 - - set args [list] - set counter 0 - foreach arg [info args $proc_name] { - if { [info default $proc_name $arg default_value] } { - lappend args [list $arg $default_value] - } else { - lappend args $arg + if {[info exists aa_testcase_id]} { + # + # Runtime testcase stub. + # If a stub for this procedure hasn't already been defined, take a copy + # of the original procedure and add it to the aa_stub_names list. + # + if {[lsearch -exact $aa_stub_names $proc_name] == -1} { + lappend aa_stub_names $proc_name + proc ${proc_name}_unstubbed [info args $proc_name] [info body $proc_name] } - } + set aa_stub_sequence($proc_name) 1 + + set args [list] + set counter 0 + foreach arg [info args $proc_name] { + if { [info default $proc_name $arg default_value] } { + lappend args [list $arg $default_value] + } else { + lappend args $arg + } + } - proc $proc_name $args " + proc $proc_name $args " global aa_stub_sequence global aa_testcase_id set sequence_id \$aa_stub_sequence\($proc_name\) incr aa_stub_sequence\($proc_name\) $new_body " - return - } else { - # - # File wide stub. - # - if {![nsv_exists aa_file_wide_stubs [info script]]} { - nsv_set aa_file_wide_stubs "[info script]" {} + return + } else { + # + # File wide stub. + # + if {![nsv_exists aa_file_wide_stubs [info script]]} { + nsv_set aa_file_wide_stubs "[info script]" {} + } + nsv_lappend aa_file_wide_stubs "[info script]" [list $proc_name $new_body] } - nsv_lappend aa_file_wide_stubs "[info script]" [list $proc_name $new_body] - } } ad_proc -public aa_unstub { - proc_name + proc_name } { - @author Peter Harper - @creation-date 24 July 2001 + @author Peter Harper + @creation-date 24 July 2001 } { set args [list] set counter 0 @@ -100,83 +100,83 @@ } } - proc $proc_name $args [info body ${proc_name}_unstubbed] - return + proc $proc_name $args [info body ${proc_name}_unstubbed] + return } ad_proc -public aa_register_init_class { - init_class_id - init_class_desc - constructor - destructor + init_class_id + init_class_desc + constructor + destructor } { - Registers a initialisation class to be used by one or more testcases. An - initialisation class can be assigned to a testcase via the - aa_register_case proc.
-
- An initialisation constructor is called once before - running a set of testcases, and the descructor called once - upon completion of running a set of testcases.
- The idea behind this is that it could be used to perform data intensive - operations that shared amoungst a set if testcases. For example, mounting - an instance of a package. This could be performed by each testcase - individually, but this would be highly inefficient if there are any - significant number of them. -
- Better to let the acs-automated-testing infrastructure call - the init_class code to set the package up, run all the tests, then call - the descructor to unmount the package. - @author Peter Harper - @creation-date 04 November 2001 + Registers a initialisation class to be used by one or more testcases. An + initialisation class can be assigned to a testcase via the + aa_register_case proc.
+
+ An initialisation constructor is called once before + running a set of testcases, and the descructor called once + upon completion of running a set of testcases.
+ The idea behind this is that it could be used to perform data intensive + operations that shared amoungst a set if testcases. For example, mounting + an instance of a package. This could be performed by each testcase + individually, but this would be highly inefficient if there are any + significant number of them. +
+ Better to let the acs-automated-testing infrastructure call + the init_class code to set the package up, run all the tests, then call + the descructor to unmount the package. + @author Peter Harper + @creation-date 04 November 2001 } { - # - # Work out the package key - # - set package_root [file join [acs_root_dir] packages] - set package_rel [string replace [info script] \ - 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 - # exists, replace it with the new version. - # - set lpos 0 - set found_pos -1 - foreach init_class [nsv_get aa_test init_classes] { - 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]] - set found_pos $lpos - break + # + # Work out the package key + # + set package_root [file join [acs_root_dir] packages] + set package_rel [string replace [info script] \ + 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 + # exists, replace it with the new version. + # + set lpos 0 + set found_pos -1 + foreach init_class [nsv_get aa_test init_classes] { + 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]] + set found_pos $lpos + break + } + incr lpos } - incr lpos - } - # - # If we haven't already replaced an existing entry, append the new - # entry to the list. - # - if {$found_pos == -1} { - nsv_lappend aa_test init_classes [list $init_class_id $package_key \ - $init_class_desc \ - [info script] \ - $constructor $destructor] - } + # + # If we haven't already replaced an existing entry, append the new + # entry to the list. + # + if {$found_pos == -1} { + nsv_lappend aa_test init_classes [list $init_class_id $package_key \ + $init_class_desc \ + [info script] \ + $constructor $destructor] + } - # - # Define the functions. Note the destructor upvars into the - # aa_runseries function to gain visibility of all the variables - # the constructor has exported. - # - ad_proc -private _${package_key}__i_$init_class_id {} " + # + # Define the functions. Note the destructor upvars into the + # aa_runseries function to gain visibility of all the variables + # the constructor has exported. + # + ad_proc -private _${package_key}__i_$init_class_id {} " aa_log \"Running \\\"$init_class_id\\\" initialisation class constructor\" $constructor " - ad_proc -private _${package_key}__d_$init_class_id {} " + ad_proc -private _${package_key}__d_$init_class_id {} " upvar _aa_exports _aa_exports foreach v \$_aa_exports(\[list $package_key $init_class_id\]) { upvar \$v \$v @@ -186,202 +186,256 @@ } ad_proc -public aa_register_component { - component_id - component_desc - body + component_id + component_desc + body } { - Registers a re-usable code component. Provide a component identifier, - description and component body code. -
- This is useful for re-using code that sets up / clears down, data common - to many testcases. - @author Peter Harper - @creation-date 28 October 2001 + Registers a re-usable code component. Provide a component identifier, + description and component body code. +
+ This is useful for re-using code that sets up / clears down, data common + to many testcases. + @author Peter Harper + @creation-date 28 October 2001 } { - # - # Work out the package key - # - set package_root [file join [acs_root_dir] packages] - set package_rel [string replace [info script] \ - 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 - # exists, replace it with the new version. - # - set lpos 0 - set found_pos -1 - foreach component [nsv_get aa_test components] { - 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]] - set found_pos $lpos - break + # + # Work out the package key + # + set package_root [file join [acs_root_dir] packages] + set package_rel [string replace [info script] \ + 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 + # exists, replace it with the new version. + # + set lpos 0 + set found_pos -1 + foreach component [nsv_get aa_test components] { + 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]] + set found_pos $lpos + break + } + incr lpos } - incr lpos - } - # - # If we haven't already replaced an existing entry, append the new - # entry to the list. - # - if {$found_pos == -1} { - nsv_lappend aa_test components [list $component_id $package_key \ - $component_desc \ - [info script] \ - $body] - } + # + # If we haven't already replaced an existing entry, append the new + # entry to the list. + # + if {$found_pos == -1} { + nsv_lappend aa_test components [list $component_id $package_key \ + $component_desc \ + [info script] \ + $body] + } - # set munged_body [subst {uplevel 1 {$body}}] - ad_proc -private _${package_key}__c_$component_id {} $body + # set munged_body [subst {uplevel 1 {$body}}] + ad_proc -private _${package_key}__c_$component_id {} $body } ad_proc -public aa_call_component { - component_id + component_id } { - Executes the chunk of code associated with the component_id.
- Call this function from within a testcase body only. - @author Peter Harper - @creation-date 28 October 2001 + Executes the chunk of code associated with the component_id.
+ Call this function from within a testcase body only.
+ @author Peter Harper
+ @creation-date 28 October 2001
} {
- global aa_package_key
- set body ""
+ global aa_package_key
+ set body ""
- #
- # Search for the component body
- #
- foreach component [nsv_get aa_test components] {
- if {$component_id == [lindex $component 0] &&
- $aa_package_key == [lindex $component 1]} {
- set body [lindex $component 4]
+ #
+ # Search for the component body
+ #
+ foreach component [nsv_get aa_test components] {
+ if {$component_id == [lindex $component 0] &&
+ $aa_package_key == [lindex $component 1]} {
+ set body [lindex $component 4]
+ }
}
- }
- #
- # If the component exists, execute the body code in the testcases stack
- # level.
- #
- if {$body != ""} {
- aa_log "Running component $component_id"
- uplevel 1 "_${aa_package_key}__c_$component_id"
- return
- } else {
- error "Unknown component $component_id, package $aa_package_key"
- }
+ #
+ # If the component exists, execute the body code in the testcases stack
+ # level.
+ #
+ if {$body != ""} {
+ aa_log "Running component $component_id"
+ uplevel 1 "_${aa_package_key}__c_$component_id"
+ return
+ } else {
+ error "Unknown component $component_id, package $aa_package_key"
+ }
}
ad_proc -public aa_register_case {
- {-cats {}}
- {-init_classes {}}
- {-on_error {}}
- testcase_id
- testcase_desc
- args
+ {-libraries {}}
+ {-cats {}}
+ {-error_level "error"}
+ {-bugs {}}
+ {-procs {}}
+ {-init_classes {}}
+ {-on_error {}}
+ testcase_id
+ testcase_desc
+ args
} {
- Registers a testcase with the acs-automated-testing system. The testcase may be
- associated with one or more categories using the -cats flag, eg:
- aa_register_case -cats {
- ...category1...
- ...category2...
- } -init_classes {
- ...init_class1...
- ...init_class2...
- } -on_error {
- ...on-error message...
- } my_test_id {
- ...code block one...
- } {
- ...code block two...
- }
-
- An optional message to display on if the test fails can be provided (see above). -
- Specify a testcase_id, and description. All other arguments are assumed - to be one or more bodys to be executed. - @author Peter Harper - @creation-date 24 July 2001 + Registers a testcase with the acs-automated-testing system. Whenever possible, cases that fail to register are replaced with 'metatest' log cases, so that the register-time errors are visible at test time. + + See the tutorial for examples. + + @param libraries A list of keywords of additional code modules to load. The entire test case will fail if any package is missing. Currently includes tclwebtest. + + @param cats Properties of the test case. Must be zero or more of the following: +
- Call this function within a testcase, stub or component. + 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. + @return True if the affirmation passed, false otherwise. - @author Peter Harper - @creation-date 24 July 2001 + @author Peter Harper + @creation-date 24 July 2001 } { - global aa_testcase_id - global aa_package_key + global aa_testcase_id + global aa_package_key - if { [string equal $affirm_actual $affirm_value] } { - aa_log_result "pass" "$affirm_name Affirm PASSED, actual = \"$affirm_actual\"" - return 1 - } else { - aa_log_result "fail" "$affirm_name Affirm FAILED, actual = \"$affirm_actual\", expected = \"$affirm_value\"" - return 0 - } + if { [string equal $affirm_actual $affirm_value] } { + aa_log_result "pass" "$affirm_name Affirm PASSED, actual = \"$affirm_actual\"" + return 1 + } else { + aa_log_result "fail" "$affirm_name Affirm FAILED, actual = \"$affirm_actual\", expected = \"$affirm_value\"" + return 0 + } } ad_proc -public aa_true { - affirm_name - affirm_expr + affirm_name + affirm_expr } { - Tests that affirm_expr is true.
- Call this function within a testcase, stub or component. - - @return True if the affirmation passed, false otherwise. + 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
+ @author Peter Harper
+ @creation-date 24 July 2001
} {
- global aa_testcase_id
- global aa_package_key
-
- set result [uplevel 1 [list expr $affirm_expr]]
- 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"
- return 0
- }
+ global aa_testcase_id
+ global aa_package_key
+
+ set result [uplevel 1 [list expr $affirm_expr]]
+ 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"
+ return 0
+ }
}
ad_proc -public aa_false {
- affirm_name
- affirm_expr
+ affirm_name
+ affirm_expr
} {
- 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
+ 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
+ global aa_testcase_id
+ global aa_package_key
- set result [uplevel 1 [list expr $affirm_expr]]
- if {!$result} {
- 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"
- return 0
- }
+ set result [uplevel 1 [list expr $affirm_expr]]
+ if {!$result} {
+ 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"
+ return 0
+ }
}
ad_proc -public aa_log {
- log_notes
+ log_notes
} {
- Writes a log message to the testcase log.
- Call this function within a testcase, stub or component. - @author Peter Harper - @creation-date 24 July 2001 + Writes a log message to the testcase log.
+ Call this function within a testcase, stub or component. + @author Peter Harper + @creation-date 24 July 2001 } { - global aa_testcase_id - global aa_package_key - global aa_run_quietly_p + global aa_testcase_id + global aa_package_key + global aa_run_quietly_p - if {$aa_run_quietly_p} { - return - } + if {$aa_run_quietly_p} { + return + } - aa_log_result "log" $log_notes + aa_log_result "log" $log_notes } ad_proc -public aa_error { - error_notes + error_notes } { - Writes an error message to the testcase log.
- Call this function within a testcase, stub or component. - @author Peter Harper - @creation-date 04 November 2001 + Writes an error message to the testcase log.
+ Call this function within a testcase, stub or component. + @author Peter Harper + @creation-date 04 November 2001 } { - aa_log_result "fail" $error_notes + aa_log_result "fail" $error_notes } ad_proc -public aa_log_result { - test_result - test_notes + test_result + test_notes } { - @author Peter Harper - @creation-date 24 July 2001 + @author Peter Harper + @creation-date 24 July 2001 } { - if { [aa_in_rollback_block_p] } { - aa_add_rollback_test [list aa_log_result $test_result $test_notes] - return - } + if { [aa_in_rollback_block_p] } { + aa_add_rollback_test [list aa_log_result $test_result $test_notes] + return + } - global aa_testcase_id - global aa_testcase_test_id - global aa_testcase_fails - global aa_testcase_passes - global aa_package_key - global aa_in_init_class - global aa_init_class_logs + global aa_testcase_id + global aa_testcase_test_id + global aa_testcase_fails + global aa_testcase_passes + global aa_package_key + global aa_in_init_class + global aa_init_class_logs + global aa_error_level - # - # If logging is happened whilst in a initialisation class, store the log - # entry, but don't write it to the database. Individual testcase will make - # their own copies of these log entries. - # - if {$aa_in_init_class != ""} { - lappend aa_init_class_logs($aa_in_init_class) \ - [list $test_result $test_notes] - return - } + # + # If logging is happened whilst in a initialisation class, store the log + # entry, but don't write it to the database. Individual testcase will make + # their own copies of these log entries. + # + if {$aa_in_init_class != ""} { + lappend aa_init_class_logs($aa_in_init_class) \ + [list $test_result $test_notes] + return + } - incr aa_testcase_test_id - if {$test_result == "pass"} { - ns_log Debug "aa_log_result: PASSED: $aa_testcase_id, $test_notes" - incr aa_testcase_passes - } elseif {$test_result == "fail"} { - ns_log Bug "aa_log_result: FAILED: $aa_testcase_id, $test_notes" - incr aa_testcase_fails - } else { - ns_log Debug "aa_log_result: LOG: $aa_testcase_id, $test_notes" - set test_result "log" - } - # Notes in database can only hold so many characters - if { [string length $test_notes] > 2000 } { - set test_notes "[string range $test_notes 0 1996]..." - } + incr aa_testcase_test_id + if {$test_result == "pass"} { + ns_log Debug "aa_log_result: PASSED: $aa_testcase_id, $test_notes" + incr aa_testcase_passes + } elseif {$test_result == "fail"} { + switch $aa_error_level { + notice { + ns_log notice "aa_log_result: NOTICE: $aa_testcase_id, $test_notes" + set test_result "note" + } + warning { + ns_log warning "aa_log_result: WARNING: $aa_testcase_id, $test_notes" + set test_result "warn" + } + error { + incr aa_testcase_fails + ns_log Bug "aa_log_result: FAILED: $aa_testcase_id, $test_notes" + } + default { + # metatest + incr aa_testcase_fails + ns_log Bug "aa_log_result: FAILED: Automated test did not function as expected: $aa_testcase_id, $test_notes" + } + } - db_dml test_result_insert {} + } else { + ns_log Debug "aa_log_result: LOG: $aa_testcase_id, $test_notes" + set test_result "log" + } + # Notes in database can only hold so many characters + if { [string length $test_notes] > 2000 } { + set test_notes "[string range $test_notes 0 1996]..." + } + + db_dml test_result_insert {} } ad_proc -public aa_log_final { - test_passes - test_fails + test_passes + test_fails } { - @author Peter Harper - @creation-date 24 July 2001 + @author Peter Harper + @creation-date 24 July 2001 } { - global aa_testcase_id - global aa_testcase_fails - global aa_testcase_passes - global aa_package_key + global aa_testcase_id + global aa_testcase_fails + global aa_testcase_passes + global aa_package_key - if {$test_fails == 0} { - } else { - ns_log Bug "aa_log_final: FAILED: $aa_testcase_id, $test_fails tests failed" - } + if {$test_fails == 0} { + } else { + ns_log Bug "aa_log_final: FAILED: $aa_testcase_id, $test_fails tests failed" + } - db_dml testcase_result_insert { - insert into aa_test_final_results - (testcase_id, package_key, timestamp, passes, fails) - values (:aa_testcase_id, :aa_package_key, sysdate, :test_passes, :test_fails) - } + db_dml testcase_result_insert { + insert into aa_test_final_results + (testcase_id, package_key, timestamp, passes, fails) + values (:aa_testcase_id, :aa_package_key, sysdate, :test_passes, :test_fails) + } } ad_proc -public 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 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 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 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 " set errmsg {} db_transaction { aa_start_rollback_block @@ -819,94 +898,94 @@ error \"\$errmsg \n\n \$errorInfo\" } " - } + } - # 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] + # Testing + set setup_error_p [catch {uplevel $test_code} setup_error] global errorInfo - set teardown_error_stack $errorInfo - } + set setup_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 - } + # 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 + } } 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 " "] + } } - } - if { [info exists aa_rollback_test_statements] } { - unset aa_rollback_test_statements - } + if { [info exists aa_rollback_test_statements] } { + unset aa_rollback_test_statements + } } @@ -917,7 +996,7 @@ {-array:required} } { Processes the xml report outputted from install.sh for display. -} +} { upvar 1 $array service set path /var/log/openacs/test/$name @@ -967,3 +1046,10 @@ } + + + + + + + \ No newline at end of file Index: openacs-4/packages/acs-automated-testing/www/admin/testcase.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-automated-testing/www/admin/testcase.adp,v diff -u -r1.9 -r1.10 --- openacs-4/packages/acs-automated-testing/www/admin/testcase.adp 12 Sep 2003 12:03:34 -0000 1.9 +++ openacs-4/packages/acs-automated-testing/www/admin/testcase.adp 15 Feb 2004 12:25:01 -0000 1.10 @@ -10,6 +10,8 @@