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 -N -r1.40 -r1.41
--- openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 27 Jun 2015 17:13:45 -0000 1.40
+++ openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 7 Aug 2017 23:47:46 -0000 1.41
@@ -1,4 +1,3 @@
-
##############################################################################
#
# Copyright 2001, OpenACS, Peter Harper.
@@ -7,7 +6,6 @@
#
##############################################################################
-
ad_library {
Procs to support the acs-automated-testing package.
@@ -34,6 +32,61 @@
}
}
+proc aa_proc_copy {proc_name_old proc_name_new {new_body ""}} {
+ #
+ # This is a single proc handling all stub management requirements
+ # from aa-testing. Since the arglist nsf::procs is not simply "args"
+ # (like for proc based ad_procs), but the real argument/parameter
+ # list, we address these differences here for all needed cases.
+ #
+ if {[info procs $proc_name_old] ne ""} {
+ #
+ # We copy a regular Tcl proc
+ #
+ set args {}
+ foreach arg [info args $proc_name_old] {
+ if { [info default $proc_name_old $arg default_value] } {
+ lappend args [list $arg $default_value]
+ } else {
+ lappend args $arg
+ }
+ }
+ set old_body [info body $proc_name_old]
+ if {$new_body eq ""} {
+ set new_body $old_body
+ }
+ set arg_parser "[namespace tail $proc_name_old]__arg_parser"
+ #
+ # In case a arg-parser was used in the old body, but is
+ # missing in the new version, add it automatically to the new
+ # body.
+ #
+ if {[string match *$arg_parser* $old_body]} {
+ if {![string match *$arg_parser* $new_body]} {
+ set new_body $arg_parser\n$new_body
+ #ns_log notice "... auto added arg_parser for '$proc_name_new' ====> new_body $new_body"
+ }
+ }
+ ::proc $proc_name_new $args $new_body
+ } elseif {$::acs::useNsfProc && [info commands $proc_name_old] ne ""} {
+ #
+ # We copy a nsf::proc
+ #
+ # Use an absolute name to reference to a nsf::proc
+ # unambiguously
+ #
+ set proc_name [namespace which $proc_name_old]
+ if {$new_body eq ""} {
+ set new_body [::nsf::cmd::info body $proc_name]
+ }
+ nsf::proc -ad $proc_name_new \
+ [::nsf::cmd::info parameter $proc_name] \
+ $new_body
+ } else {
+ error "no such proc $proc_name_old"
+ }
+}
+
ad_proc -public aa_stub {
proc_name
new_body
@@ -58,21 +111,11 @@
#
if {$proc_name ni $aa_stub_names} {
lappend aa_stub_names $proc_name
- proc ${proc_name}_unstubbed [info args $proc_name] [info body $proc_name]
+ aa_proc_copy $proc_name ${proc_name}_unstubbed
}
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 "
+ aa_proc_copy $proc_name $proc_name "
global aa_stub_sequence
global aa_testcase_id
set sequence_id \$aa_stub_sequence\($proc_name\)
@@ -85,9 +128,9 @@
# File wide stub.
#
if {![nsv_exists aa_file_wide_stubs [info script]]} {
- nsv_set 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]
}
}
@@ -97,17 +140,7 @@
@author Peter Harper
@creation-date 24 July 2001
} {
- 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 [info body ${proc_name}_unstubbed]
+ aa_proc_copy ${proc_name}_unstubbed $proc_name
return
}
@@ -125,7 +158,7 @@
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
+ operations that shared amongst 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.
@@ -302,7 +335,7 @@
} {
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.
+ 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.
@@ -316,14 +349,14 @@
security_risk: May introduce a security risk.
populator: Creates sample data for future use.
production_safe: Can be used on a live production site, ie for sanity checking or keepalive purposes. Implies: no risk of adding or deleting data; no risk of crashing; minimal cpu/db/net load.
-
+
@param error_level Force all test failures to this error level. One of
-
-- notice: Informative. Does not indicate an error.
-
- warning: May indicate an problem. Example: a non-critical bug repro case that hasn't been fixed.
-
- error: normal error
-
- metatest: Indicates a problem with the test framework, execution, or reporting. Suggests that current test results may be invalid. Use this for test cases that test the tests. Also used, automatically, for errors sourcing test cases.
-
+
+ - notice: Informative. Does not indicate an error.
+
- warning: May indicate an problem. Example: a non-critical bug repro case that hasn't been fixed.
+
- error: normal error
+
- metatest: Indicates a problem with the test framework, execution, or reporting. Suggests that current test results may be invalid. Use this for test cases that test the tests. Also used, automatically, for errors sourcing test cases.
+
@param bugs A list of integers correspending to openacs.org bug numbers which relate to this test case.
@param procs A list of OpenACS procs which are tested by this case.
@@ -365,7 +398,7 @@
if { $library eq "tclwebtest" } {
# kludge: until tclwebtest installs itself in the proper
- # place following the tcl way, we use this absolute path
+ # place following the Tcl way, we use this absolute path
# hack.
set tclwebtest_absolute_path "/usr/local/tclwebtest/lib"
if { ![info exists ::auto_path] || [lsearch $::auto_path $tclwebtest_absolute_path] == -1 } {
@@ -480,8 +513,7 @@
aa_log \"Running testcase body \$body_count\"
set catch_val \[catch \"eval \[list \$testcase_body\]\" msg\]
if {\$catch_val != 0 && \$catch_val != 2} {
- global errorInfo
- aa_log_result \"fail\" \"$testcase_id (body \$body_count): Error during execution: \${msg}, stack trace: \n\$errorInfo\"
+ aa_log_result \"fail\" \"$testcase_id (body \$body_count): Error during execution: \${msg}, stack trace: \n\$::errorInfo\"
}
incr body_count
}
@@ -901,11 +933,7 @@
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 {}
}
ad_proc -public aa_run_with_teardown {
@@ -943,23 +971,20 @@
aa_execute_rollback_tests
if { \$errmsg ne {} && \$errmsg ne \"rollback tests\"\ } {
- global errorInfo
- error \"\$errmsg \n\n \$errorInfo\"
+ error \"\$errmsg \n\n \$::errorInfo\"
}
"
}
# Testing
set setup_error_p [catch {uplevel $test_code} setup_error]
- global errorInfo
- set setup_error_stack $errorInfo
+ set setup_error_stack $::errorInfo
# Teardown
set teardown_error_p 0
if { $teardown_code ne "" } {
set teardown_error_p [catch {uplevel $teardown_code} teardown_error]
- global errorInfo
- set teardown_error_stack $errorInfo
+ set teardown_error_stack $::errorInfo
}
# Provide complete error message and stack trace
@@ -1104,8 +1129,8 @@
# TODO: Not working
set service(admin_login_url) [export_vars -base $service(url)register/ {
- { email $service(adminemail) }
- { password $service(adminpassword) }
+ { email $service(adminemail) }
+ { password $service(adminpassword) }
}]
set service(auto_test_url) "$service(url)test/admin"
set service(rebuild_cmd) "sh [file join $service(script_path) recreate.sh]"
@@ -1126,7 +1151,7 @@
db_foreach result_counts {
select result,
- count(*) as result_count
+ count(*) as result_count
from aa_test_results
group by result
} {
@@ -1139,7 +1164,7 @@
db_foreach failure_counts {
select testcase_id,
- count(*) as failure_count
+ count(*) as failure_count
from aa_test_results
where result = 'fail'
group by testcase_id
@@ -1174,7 +1199,7 @@
set file_path "$report_dir/${hostname}-${server}-testreport.xml"
set xml_doc [get_test_doc]
-
+
if { [catch {template::util::write_file $file_path $xml_doc} errmsg] } {
ns_log Error "Failed to write xml test report to path $file_path - $errmsg"
}
@@ -1219,15 +1244,15 @@
ad_proc -public aa_get_first_url {
{-package_key:required}
} {
- Procedure for geting the url of a mounted package with the package_key. It uses the first instance that it founds. This is usefull for tclwebtest tests.
+ Procedure for geting the url of a mounted package with the package_key. It uses the first instance that it founds. This is useful for tclwebtest tests.
} {
- if {![db_0or1row first_url { *SQL* }]} {
+ if {![db_0or1row first_url {}]} {
site_node::instantiate_and_mount -package_key $package_key
- db_1row first_url {*SQL*}
-}
+ db_1row first_url {}
+ }
- return $url
+ return $url
}
@@ -1243,9 +1268,9 @@
@param explanation An explanation accompanying the response.
} {
if {$response} {
- aa_log_result "pass" $explanation
+ aa_log_result "pass" $explanation
} else {
- aa_log_result "fail" $explanation
+ aa_log_result "fail" $explanation
}
}
@@ -1265,7 +1290,7 @@
# request.
return $_acs_automated_testing_selenium_init
}
-
+
set server_url [parameter::get_from_package_key \
-package_key acs-automated-testing \
-parameter "SeleniumRcServer" \
@@ -1295,3 +1320,10 @@
"Init Class for Selenium Remote Control" \
{aa_selenium_init} \
{catch {Se stop} errmsg}
+
+#
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End: