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 - + @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: