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.79 -r1.80 --- openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 4 Oct 2018 10:02:14 -0000 1.79 +++ openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 3 Sep 2024 15:37:30 -0000 1.80 @@ -9,23 +9,24 @@ ad_library { 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$ } -# 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. +# +# 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 api web smoke stress security_risk populator production_safe } nsv_set aa_test exclusion_categories { stress security_risk } - if {[parameter::get_from_package_key -package_key "acs-automated-testing" -parameter "SeleniumRcServer"] ne ""} { + if {[parameter::get_from_package_key \ + -package_key "acs-automated-testing" \ + -parameter "SeleniumRcServer"] ne "" + } { nsv_lappend aa_test categories "selenium" } else { nsv_lappend aa_test exclusion_categories "selenium" @@ -68,7 +69,7 @@ } } ::proc $proc_name_new $args $new_body - } elseif {$::acs::useNsfProc && [info commands $proc_name_old] ne ""} { + } elseif {$::acs::useNsfProc && [namespace which $proc_name_old] ne ""} { # # We copy a nsf::proc # @@ -99,27 +100,23 @@ @author Peter Harper @creation-date 24 July 2001 } { - global aa_stub_sequence - global aa_stub_names - global aa_testcase_id - - if {[info exists 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. + # of the original procedure and add it to the ::aa_stub_names list. # - if {$proc_name ni $aa_stub_names} { - lappend aa_stub_names $proc_name + if {$proc_name ni $::aa_stub_names} { + lappend ::aa_stub_names $proc_name aa_proc_copy $proc_name ${proc_name}_unstubbed } - set aa_stub_sequence($proc_name) 1 + set ::aa_stub_sequence($proc_name) 1 aa_proc_copy $proc_name $proc_name " global aa_stub_sequence global aa_testcase_id - set sequence_id \$aa_stub_sequence\($proc_name\) - incr aa_stub_sequence\($proc_name\) + set sequence_id \$::aa_stub_sequence\($proc_name\) + incr ::aa_stub_sequence\($proc_name\) $new_body " return @@ -137,6 +134,9 @@ ad_proc -public aa_unstub { proc_name } { + Copies (back) a proc with "_unstubbed" suffix to its supposedly + unpostfixed original name. + @author Peter Harper @creation-date 24 July 2001 } { @@ -150,7 +150,7 @@ constructor destructor } { - Registers a initialization class to be used by one or more testcases. An + Registers an initialization class to be used by one or more testcases. An initialization class can be assigned to a testcase via the aa_register_case proc. @@ -238,10 +238,10 @@ component_desc body } { - Registers a re-usable code component. Provide a component identifier, + Registers a reusable 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 + This is useful for reusing code that sets up / clears down, data common to many testcases. @author Peter Harper @creation-date 28 October 2001 @@ -296,15 +296,14 @@ @author Peter Harper @creation-date 28 October 2001 } { - 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]} { + if {$component_id == [lindex $component 0] && + $::aa_package_key == [lindex $component 1]} { set body [lindex $component 4] } } @@ -315,10 +314,10 @@ # if {$body ne ""} { aa_log "Running component $component_id" - uplevel 1 "_${aa_package_key}__c_$component_id" + uplevel 1 "_${::aa_package_key}__c_$component_id" return } else { - error "Unknown component $component_id, package $aa_package_key" + error "Unknown component $component_id, package $::aa_package_key" } } @@ -373,7 +372,7 @@ 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 bugs A list of integers corresponding to openacs.org bug numbers which relate to this test case. @param procs A list of OpenACS procs which are tested by this case. @param urls A list of URLs (relative to package) tested in web test case @@ -461,6 +460,7 @@ $cats $init_classes $on_error $args $error_level \ $bugs $procs $urls] foreach p $procs { + set p [string trimleft $p :] api_add_to_proc_doc -proc_name $p -property testcase -value [list $testcase_id $package_key] #ns_log notice "TESTCASE: api_add_to_proc_doc -proc_name $p -property testcase -value $testcase_id -> [dict get [nsv_get api_proc_doc $p] testcase]" } @@ -506,48 +506,49 @@ if {[llength $init_classes] == 0} { set init_class_code "" } else { - set init_class_code " - global aa_init_class_logs - upvar 2 _aa_exports _aa_exports - foreach init_class \[list $init_classes\] { - if {[llength $init_class] == 2} { - lassign $init_class init_class init_package_key - } else { - set init_package_key $package_key - } - foreach v \$_aa_exports(\[list \$init_package_key \$init_class\]) { - upvar 2 \$v \$v - } - foreach logpair \$aa_init_class_logs(\[list \$init_package_key \$init_class\]) { - aa_log_result \[lindex \$logpair 0\] \[lindex \$logpair 1\] - } + set init_class_code [string map [ + list @init_classes@ [list $init_classes] @package_key@ [list $package_key]] { + upvar 2 _aa_exports _aa_exports + foreach init_class @init_classes@ { + if {[llength $init_class] == 2} { + lassign $init_class init_class init_package_key + } else { + set init_package_key @package_key@ + } + foreach v $_aa_exports([list $init_package_key $init_class]) { + upvar 2 $v $v + } + foreach logpair $::aa_init_class_logs([list $init_package_key $init_class]) { + aa_log_result [lindex $logpair 0] [lindex $logpair 1] + } + } + }] } - " - } - set body " - $init_class_code - set _aa_export {} - set body_count 1 - foreach testcase_body \[list $args\] { - aa_log \"Running testcase body \$body_count\" - set catch_val \[catch \"eval \[list \$testcase_body\]\" msg\] - if {\$catch_val != 0 && \$catch_val != 2} { - aa_log_result \"fail\" \"$testcase_id (body \$body_count): Error during execution: \${msg}, stack trace: \n\$::errorInfo\" - } - incr body_count - } - " + set body [string map [list @init_class_code@ $init_class_code @args@ [list $args] @testcase_id@ [list $testcase_id]] { + @init_class_code@ + set _aa_export {} + set body_count 1 + foreach testcase_body @args@ { + aa_log "Running testcase body $body_count" + set ::__aa_test_indent [info level] + set catch_val [catch $testcase_body msg] + if {$catch_val != 0 && $catch_val != 2} { + aa_log_result "fail" "@testcase_id@ (body $body_count): Error during execution: $msg, stack trace: \n$::errorInfo" + } + incr body_count + } + }] ad_proc -private _${package_key}__$testcase_id {} $body ns_log Debug "aa_register_case: Registered test case $testcase_id in package $package_key" } ad_proc -public aa_export_vars { - args + varnames } { - Called from a initialization class constructor or a component to + Called from an initialization class constructor or a component to explicitly export the specified variables to the current testcase. You need to call aa_export_vars before you create the variables. @@ -558,36 +559,37 @@ set item_id 109 } { - uplevel " - foreach v $args { - upvar \$v \$v - uplevel 1 \"lappend _aa_export \$v\" - } - " + uplevel 1 [string map [list @varnames@ [list $varnames]] { + foreach v @varnames@ { + upvar $v $v + uplevel 1 [list lappend _aa_export $v] + } + }] } -ad_proc -public aa_runseries { +ad_proc -private aa_runseries { {-stress 0} {-security_risk 0} -quiet:boolean {-testcase_id ""} - {by_package_key ""} + {by_package_keys ""} {by_category ""} } { Runs a series of testcases. - Runs all cases if both package_key and - category are blank, otherwise it uses the package and/or category to - select which testcases to run. + Runs all cases if both by_package_keys and by_category are blank, + otherwise it uses the package and/or category to select which + testcases to run. @author Peter Harper @creation-date 24 July 2001 } { - global aa_run_quietly_p - global aa_init_class_logs - global aa_in_init_class + # probably transitional code for testing purposes + if {[info commands ::aa::coverage::add_traces] ne ""} { + catch {aa::coverage::add_traces} + } - set aa_run_quietly_p $quiet_p + set ::aa_run_quietly_p $quiet_p # # Work out the list of initialization classes. # @@ -612,8 +614,8 @@ # try to disqualify the test case - # if category is specified, - if { $by_package_key ne "" && $by_package_key ne $package_key } { + # check if package key belongs to the ones we are testing + if { $by_package_keys ne "" && $package_key ni $by_package_keys } { continue } @@ -648,19 +650,27 @@ foreach initpair [array names classes] { lassign $initpair package_key init_class set _aa_export {} - set aa_init_class_logs([list $package_key $init_class]) {} - set aa_in_init_class [list $package_key $init_class] + set ::aa_init_class_logs([list $package_key $init_class]) {} + set ::aa_in_init_class [list $package_key $init_class] _${package_key}__i_$init_class set _aa_exports([list $package_key $init_class]) $_aa_export } } - set aa_in_init_class "" + set ::aa_in_init_class "" # # Run each testcase # - foreach testcase_id $testcase_ids { + foreach testcase_id [lsort $testcase_ids] { + set logStats [ns_logctl stats] + ns_log notice "========================================= start $testcase_id" \ + "(Errors: [dict get $logStats Error], Warnings: [dict get $logStats Warning], Bugs: [dict get $logStats Bug])" + aa_test_start aa_run_testcase $testcase_id + aa_test_end + set logStats [ns_logctl stats] + ns_log notice "========================================= end $testcase_id" \ + "(Errors: [dict get $logStats Error], Warnings: [dict get $logStats Warning], Bugs: [dict get $logStats Bug])" } # @@ -669,38 +679,37 @@ if {[info exists classes]} { foreach initpair [array names classes] { lassign $initpair package_key init_class - set aa_in_init_class [list $package_key $init_class] + set ::aa_in_init_class [list $package_key $init_class] _${package_key}__d_$init_class } } - set aa_in_init_class "" + set ::aa_in_init_class "" # Generate the XML report file aa_test::write_test_file } +ad_proc -private aa_indent {} { + try to make it easier to read nested test cases. +} { + if {[info exists ::__aa_test_indent]} { + return "[string repeat {} [expr {[info level] - $::__aa_test_indent -2}]]" + } +} -ad_proc -public aa_run_testcase { +ad_proc -private aa_run_testcase { testcase_id } { @author Peter Harper @creation-date 24 July 2001 } { - global aa_stub_names - global aa_testcase_id - global aa_testcase_test_id - global aa_testcase_fails - global aa_testcase_passes - global aa_package_key - global aa_init_class_logs - global aa_error_level upvar exports exports - set aa_stub_names {} - set aa_testcase_id $testcase_id - set aa_testcase_test_id 0 - set aa_testcase_fails 0 - set aa_testcase_passes 0 + set ::aa_stub_names {} + set ::aa_testcase_id $testcase_id + set ::aa_testcase_test_id 0 + set ::aa_testcase_fails 0 + set ::aa_testcase_passes 0 # # Lookup the testcase definition. @@ -714,16 +723,14 @@ set testcase_inits [lindex $testcase 5] set testcase_on_error [lindex $testcase 6] set testcase_bodys [lindex $testcase 7] - set aa_error_level [lindex $testcase 8] - - set aa_package_key $package_key + set ::aa_error_level [lindex $testcase 8] + set ::aa_package_key $package_key } } if {[llength $testcase_bodys] == 0} { return } - # # Create any file-wide stubs. # @@ -736,12 +743,8 @@ # # Run the test # - set sql "delete from aa_test_results - where testcase_id = :testcase_id" - db_dml delete_testcase_results $sql - set sql "delete from aa_test_final_results - where testcase_id = :testcase_id" - db_dml delete_testcase_final_results $sql + db_dml delete_testcase_results {delete from aa_test_results where testcase_id = :testcase_id} + db_dml delete_testcase_final_results {delete from aa_test_final_results where testcase_id = :testcase_id} ns_log debug "aa_run_testcase: Running testcase $testcase_id" @@ -750,16 +753,25 @@ aa_log_result "fail" "$testcase_id: Error calling testcase function _${package_key}__$testcase_id: $msg" } + aa_check_leftovers -silent end + # # Unstub any stubbed functions # - foreach stub_name $aa_stub_names { + foreach stub_name $::aa_stub_names { aa_unstub $stub_name } - set aa_stub_names {} + set ::aa_stub_names {} - aa_log_final $aa_testcase_passes $aa_testcase_fails - unset aa_testcase_id + aa_log_final $::aa_testcase_passes $::aa_testcase_fails + unset ::aa_testcase_id + + # + # Cleanup temporary XOTcl objects + # + if {[namespace which ::xo::at_cleanup] ne ""} { + ::xo::at_cleanup + } } @@ -776,14 +788,11 @@ @author Peter Harper @creation-date 24 July 2001 } { - global aa_testcase_id - global aa_package_key - if {$affirm_actual eq $affirm_value} { - aa_log_result "pass" [subst {$affirm_name, actual = "$affirm_actual"}] + aa_log_result "pass" [subst {[aa_indent] $affirm_name, actual = "$affirm_actual"}] return 1 } else { - aa_log_result "fail" [subst {$affirm_name, actual = "$affirm_actual", expected = "$affirm_value"}] + aa_log_result "fail" [subst {[aa_indent] $affirm_name, actual = "$affirm_actual", expected = "$affirm_value"}] return 0 } } @@ -807,10 +816,10 @@ set expr [subst {"$affirm_expr" }] } if { $result } { - aa_log_result "pass" "$affirm_name: $expr true" + aa_log_result "pass" "[aa_indent] $affirm_name: $expr true" return 1 } else { - aa_log_result "fail" "$affirm_name: $expr false" + aa_log_result "fail" "[aa_indent] $affirm_name: $expr false" return 0 } } @@ -827,39 +836,59 @@ @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" [subst {$affirm_name: "$affirm_expr" false}] + aa_log_result "pass" [subst {[aa_indent] $affirm_name: "$affirm_expr" false}] return 1 } else { - aa_log_result "fail" [subst {$affirm_name: "$affirm_expr" true}] + aa_log_result "fail" [subst {[aa_indent] $affirm_name: "$affirm_expr" true}] return 0 } } ad_proc -public aa_section { - log_notes + log_notes } { - Writes a log message indicating a new section to the log file. + Writes a log message indicating a new section to the log files. } { aa_log_result "sect" $log_notes + ns_log notice "--------- aa_section" $log_notes } -ad_proc -public aa_log { - log_notes +ad_proc -public aa_test_running_p {} { + + Check, if the regression test is currently running. + + @return boolean value indicating state } { + return [info exists ::__aa_testing_mode] +} + +ad_proc -public aa_test_start {} { + + Set the start flag of the regression test case. +} { + return [set ::__aa_testing_mode 1] +} + +ad_proc -private aa_test_end {} { + + Clear the flag indicating that a regressoin test is running. It + is not always necessary to call this procedurfe explicitly, since + the server cleanup clears this flag automatically. + +} { + unset -nocomplain ::__aa_testing_mode 1 +} + +ad_proc -public aa_log { args } { 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 - + set log_notes [join $args " "] # # When aa_run_quietly_p exists, we run inside the testing # environment. @@ -868,7 +897,7 @@ if {$::aa_run_quietly_p} { return } - aa_log_result "log" $log_notes + aa_log_result "log" "[aa_indent] $log_notes" } else { # # Use plain ns_log reporting @@ -890,90 +919,104 @@ ad_proc -public aa_log_result { test_result - test_notes + args } { + Log a test result + @author Peter Harper @creation-date 24 July 2001 } { + set test_notes [join $args ""] 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_error_level - # - # If logging is happened whilst in a initialization class, store the log + # When aa_run_quietly_p exists, we run inside the testing + # environment. Otherwise, report and return. + # + if {![info exists ::aa_run_quietly_p]} { + ns_log warning "aa_log_result: called outside the testing environment." \ + "Test result: $test_result Test notes: $test_notes" + return + } + # + # If logging is happened whilst in an initialization 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 ne ""} { - lappend aa_init_class_logs($aa_in_init_class) \ + if {$::aa_in_init_class ne ""} { + lappend ::aa_init_class_logs($::aa_in_init_class) \ [list $test_result $test_notes] return } - incr aa_testcase_test_id + incr ::aa_testcase_test_id if {$test_result eq "pass"} { - ns_log Debug "aa_log_result: PASSED: $aa_testcase_id, $test_notes" - incr aa_testcase_passes + ns_log Debug "aa_log_result: PASSED: $::aa_testcase_id, $test_notes" + incr ::aa_testcase_passes } elseif {$test_result eq "fail"} { - switch $aa_error_level { + switch $::aa_error_level { notice { - ns_log notice "aa_log_result: NOTICE: $aa_testcase_id, $test_notes" + 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" + 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" + 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" + incr ::aa_testcase_fails + ns_log Bug "aa_log_result: FAILED: Automated test did not function as expected:" \ + "$::aa_testcase_id, $test_notes" } } } elseif {$test_result ne "sect"} { - ns_log Debug "aa_log_result: LOG: $aa_testcase_id, $test_notes" + 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 {} + global aa_package_key + global aa_testcase_test_id + global aa_testcase_id + + db_dml test_result_insert { + insert into aa_test_results + (testcase_id, package_key, test_id, timestamp, result, notes) + values (:aa_testcase_id, :aa_package_key, :aa_testcase_test_id, + current_timestamp, :test_result, :test_notes) + } } -ad_proc -public aa_log_final { +ad_proc -private aa_log_final { test_passes test_fails } { @author Peter Harper @creation-date 24 July 2001 } { + if {$test_fails > 0} { + ns_log Bug "aa_log_final: FAILED: $::aa_testcase_id, $test_fails tests failed" + } + 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" + 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, current_timestamp, :test_passes, :test_fails) } - - db_dml testcase_result_insert {} } ad_proc -public aa_run_with_teardown { @@ -995,35 +1038,39 @@ @author Peter Marklund } { if { $rollback_p } { - set test_code " + set test_code [string map [list @test_code@ $test_code] { set errmsg {} db_transaction { aa_start_rollback_block - $test_code + @test_code@ aa_end_rollback_block - error \"rollback tests\" + error "rollback tests" } on_error { + # + # Execute the rollback block and trigger error. + # aa_end_rollback_block + set errmsg [lindex [split $::errorInfo \n] 0] } aa_execute_rollback_tests - if { \$errmsg ne {} && \$errmsg ne \"rollback tests\"\ } { - error \"\$errmsg \n\n \$::errorInfo\" + if { $errmsg ne {} && $errmsg ne "rollback tests" } { + error "$errmsg \n\n $::errorInfo" } - " + }] } # Testing - set setup_error_p [catch {uplevel $test_code} setup_error] + set setup_error_p [catch {uplevel 1 $test_code} setup_error] 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] + set teardown_error_p [catch {uplevel 1 $teardown_code} teardown_error] set teardown_error_stack $::errorInfo } @@ -1107,132 +1154,246 @@ namespace eval acs::test { + ad_proc -public ::acs::test::require_package_instance { + -package_key:required + {-instance_name ""} + {-empty:boolean} + } { + Returns a test instance of specified package_key mounted under + specified name. Will create it if it is not found. It is + currently assumed the instance will be mounted under the main + subsite. + + @param package_key package to be instantiated + @param instance_name name of the site-node this instance will + be mounted to. Will default to -test + @param empty require an empty instance. If an existing + instance is found, it will be deleted. If a package + different than is found, it won't be + deleted and the proc will return an error + + @return a package_id + } { + set main_node_id [site_node::get_element \ + -url / -element node_id] + + set instance_name [expr {$instance_name eq "" ? + "${package_key}-test" : [string trim $instance_name /]}] + + set package_exists_p [db_0or1row lookup_test_package { + select node_id, object_id as package_id + from site_nodes + where parent_id = :main_node_id + and name = :instance_name + and object_id is not null + }] + + if {$package_exists_p} { + set existing_package_key [apm_package_key_from_id $package_id] + if {$existing_package_key ne $package_key} { + error "An instance of '$existing_package_key' is already mounted at '$instance_name'" + } elseif {$empty_p} { + site_node::delete -node_id $node_id -delete_package + } + } + + if {!$package_exists_p || $empty_p} { + set package_id [site_node::instantiate_and_mount \ + -package_name $instance_name \ + -node_name $instance_name \ + -package_key $package_key] + } + + return $package_id + } + ad_proc -public ::acs::test::form_reply { - -user_id:required - -url:required + {-user_id 0} + {-last_request ""} + {-form ""} + {-url ""} {-update {}} - form_content + {-remove {}} + {form_content ""} } { Send a (POST) request to the specified URL based on the provided form_content which has the form of a dict. For convenience the update fields are provided to overload the form_content. + @param last_request pass optionally the past request, from which cookie and login-info can be taken + @param update key/attribute list of values to be updated in the form content + @param remove keys to be removed from the form content + } { + if {$form_content eq ""} { + set form_content [form_get_fields $form] + aa_log "FORM-CONTENT from FORM '$form_content'" + } + if {$form_content eq ""} { + error "either nonempty form or form_content has to be provided" + } + if {$url eq ""} { + set url [dict get $form @action] + } + if {$url eq ""} { + error "either form with action fields or URL has to be provided" + } + + if {$remove ne ""} { + set form_content [dict remove $form_content {*}$remove] + ns_log notice "DEBUG: after removing <$remove> from <$form_content>" + } + + # + # Update the values coming from the form with our values. + # foreach {att value} $update { - dict set form_content $att $value + if {[regexp {^(.*)\.(tmpfile|content-type)$} $att _ fieldname type]} { + # + # This parameter is the attribute of a file. + # + lappend files($fieldname) $type $value + } else { + # + # This is a normal parameter + # + dict set form_content $att $value + } } - #ns_log notice "final form_content $form_content" + # - # Transform the dict into export format. Since export_vars - # will skip all names containing a ":", such as - # "formbutton:ok", we do this "manually". + # Cleanup all form parameters that will be sent as files # - set export {} - foreach {att value} $form_content { - lappend export [ad_urlencode_query $att]=[ad_urlencode_query $value] + set form_content [dict remove $form_content {*}[array names files]] + + # + # Now take all of the parameters that are files and build up + # the list to pass to the payload creation. + # + set fs {} + foreach {fieldname attrs} [array get files] { + if {![dict exists $attrs tmpfile]} { + error "'$fieldname' looks like a file upload, but no .tmpfile was specified" + } + set f [list \ + fieldname $fieldname \ + file [dict get $attrs tmpfile]] + if {[dict exists $attrs content_type]} { + lappend f mime_type [dict get $attrs content_type] + } + lappend fs $f } - set body [join $export &] - ns_log notice "body=$body" + + set payload [util::http::post_payload \ + -files $fs \ + -formvars_list $form_content] # # Send the POST request # return [http \ -user_id $user_id \ - -method POST -body $body \ - -headers {Content-Type application/x-www-form-urlencoded} \ + -last_request $last_request \ + -method POST \ + -body [dict get $payload payload] \ + -headers [ns_set array [dict get $payload headers]] \ $url] } + ad_proc -public ::acs::test::url {} { + @return the test URL representing our system for testing. This + would normally look like the output of ns_conn location, + unless it was overridden via the TestURL parameter in this + package. + } { + # + # Check, if a testURL was specified in the config file + # + # ns_section ns/server/${server}/acs/acs-automated-testing + # ns_param TestURL http://127.0.0.1:8080/ + # + set url [parameter::get \ + -package_id [apm_package_id_from_key acs-automated-testing] \ + -parameter TestURL \ + -default ""] + if {$url eq ""} { + set url [ns_conn location] + } + + return $url + } + ad_proc -public ::acs::test::http { {-user_id 0} {-user_info ""} + {-last_request ""} {-method GET} - {-session ""} {-body} {-timeout 10} + {-depth 1} {-headers ""} {-prefix ""} - {-verbose:boolean 1} + {-verbose:boolean true} + {-basic_auth:boolean false} request } { Run an HTTP request against the actual server inside test cases. + @param depth follow redirects up to specified depth. Default + means redirects won't be followed. + @author Gustaf Neumann } { - ns_log notice "::acs::test::http -user_id $user_id -user_info $user_info request $request" - # - # Check, if a testURL was specified in the config file - # - # ns_section ns/server/${server}/acs/acs-automated-testing - # ns_param TestURL http://127.0.0.1:8080/ - # - set url [parameter::get \ - -package_id [apm_package_id_from_key acs-automated-testing] \ - -parameter TestURL \ - -default ""] - if {$url ne ""} { - set urlInfo [ns_parseurl $url] - set proto [dict get $urlInfo proto] - set address [dict get $urlInfo host] - } else { - # - # There is no configuration in the config file. So try to - # determine it form either the current connection, or from - # the configured driver. - # - try { - # - # First try to get actual information from the - # connection. This is however only available in newer - # versions of NaviServer. The actual information is - # e.g. necessary, when the driver address is set to - # "0.0.0.0" or "::0" etc, and therefore every address - # might be provided as peer address in the check in - # the security-procs. - # - set address [ns_conn currentaddr] - set port [ns_conn currentport] - set proto [ns_conn proto] - } on error {errorMsg} { - # - # If this fails, fall back to configured value. - # - set driverInfo [util_driver_info] - set address [dict get $driverInfo address] - set port [dict get $driverInfo port] - set proto [dict get $driverInfo proto] - } - set url "$proto://\[$address\]:$port/$request" + ns_log notice "::acs::test::http -user_id '$user_id' -user_info '$user_info' request '$request'" + set session "" + if {[dict exists $last_request session]} { + set session [dict get $last_request session] } + if {$user_info eq "" && [dict exists $session user_info]} { + set user_info [dict get $last_request session user_info] + #aa_log "user_info from last_request [ns_quotehtml <$user_info>]" + } + #aa_log "HTTP: user_info [ns_quotehtml <$user_info>]" + #aa_log "HTTP: start session_info [ns_quotehtml <$session>]" + set test_url [acs::test::url] + set urlInfo [ns_parseurl $test_url] + set address [dict get $urlInfo host] + set url ${test_url}/${request} + # - # either authenticate via user_info (when specified) or via user_id + # Either authenticate via user_info (when specified) or via + # user_id. # if {$user_info ne ""} { } else { - dict set user_info address $address dict set user_info user_id $user_id + dict set user_info address $address } set session [::acs::test::set_user -session $session $user_info] - set login [dict get $session login] - #aa_log "login $login" if {[dict exists $session cookies]} { lappend headers Cookie [dict get $session cookies] } - set extra_args {} if {[info exists body]} { lappend extra_args -body $body } + if {[dict exists $user_info email] + && [dict exists $user_info password] + } { + set ah [ns_base64encode [dict get $user_info email]:[dict get $user_info password]] + aa_log "... user_info $user_info AH $ah" + lappend headers Authorization "Basic $ah" + } + if {[llength $headers] > 0} { set requestHeaders [ns_set create] foreach {tag value} $headers { @@ -1241,7 +1402,6 @@ lappend extra_args -headers $requestHeaders } - # # Construct a nice log line # @@ -1250,46 +1410,90 @@ append log_line " (headers: $headers)" } if {[info exists body]} { - append log_line "\n$body" + append log_line "

\n[ns_quotehtml $body]
" } aa_log $log_line # # Run actual request # + set d "" try { - ns_log notice "acs::test:http client request (timeout $timeout): $method $url" - set d [ns_http run \ - -timeout $timeout \ - -method $method \ - {*}$extra_args \ - $url] + set location $url + while {$depth > 0} { + ns_log notice "acs::test::http client request (timeout $timeout): $method $location" + incr depth -1 + set d [ns_http run \ + -timeout $timeout \ + -method $method \ + {*}$extra_args \ + $location] + set status [dict get $d status] + set location [ns_set iget [dict get $d headers] location] + if {![string match "3??" $status] || $location eq ""} { + break + } + + # + # According to + # https://www.rfc-editor.org/rfc/rfc7231#section-7.1.2, + # the location header may return a relative URL as + # well. + # + set location [ns_absoluteurl $location $test_url] + } } finally { # - # always reset after the reqest the login data nsv + # always reset after the request the login data nsv # nsv_unset -nocomplain aa_test logindata } + #ns_log notice "run $request returns $d" #ns_log notice "... [ns_set array [dict get $d headers]]" + if {$verbose_p} { set ms [format %.2f [expr {[ns_time format [dict get $d time]] * 1000.0}]] aa_log "${prefix}$method $request returns [dict get $d status] in ${ms}ms" } + + #aa_log "REPLY has headers [dict exists $d headers]" if {[dict exists $d headers]} { set cookies {} set cookie_dict {} + if {[dict exists $last_request cookies]} { + # + # Merge last request cookies + # + foreach cookie [split [dict get $last_request cookies] ";"] { + lassign [split [string trim $cookie] =] name value + dict set cookie_dict $name $value + #aa_log "merge last request cookie $name $value" + } + } else { + #aa_log "last_req has no cookies" + } if {[dict exists $session cookies]} { + # + # Merge session cookies (e.g. from a called login + # inside :acs::test::set_user) + # foreach cookie [split [dict get $session cookies] ";"] { lassign [split [string trim $cookie] =] name value dict set cookie_dict $name $value + #aa_log "merge session cookie $name $value" } } + # + # Merge fresh cookies + # foreach {tag value} [ns_set array [dict get $d headers]] { + #aa_log "received header $tag: $value" if {$tag eq "set-cookie"} { if {[regexp {^([^;]+);} $value . cookie]} { lassign [split [string trim $cookie] =] name value dict set cookie_dict $name $value + aa_log "merge fresh cookie $name $value" } else { aa_log "Cookie has invalid syntax: $value" } @@ -1298,24 +1502,35 @@ foreach cookie_name [dict keys $cookie_dict] { lappend cookies $cookie_name=[dict get $cookie_dict $cookie_name] } - dict set d cookies [join $cookies ";"] + dict set d session cookies [join $cookies ";"] } dict set d login $login + dict set d session user_info $user_info + #aa_log "HTTP: URL $url final session_info [ns_quotehtml <[dict get $d session]>]" + return $d } - ad_proc -public ::acs::test::set_user { + ad_proc -private ::acs::test::set_user { {-session ""} user_info } { - Depending on the provided user_info, either login in or - perform the direct test-specific authentication. When the - user_id is provided, use it directly. + When (login) cookies are given as member of "session", use + these. In case the login cookie is empty (after an explicit + logout) do NOT automatically log in. - @param user_info dict containing user_id and/or + When (login) cookies are not given, use "user_info" for + authentication. When we have a "user_id" and "address" in the + "user_info", use these for direct logins. Otherwise the person + info (name, email, ...) to log via register. + + @param session when given, use login information from there + @param user_info dict containing user_id+session and/or email, last_name, username and password } { + #aa_log "set_user has user_info $user_info, have cookies: [dict exists $session cookies]" + set already_logged_in 0 # # First check, if the user is already logged in via cookies @@ -1333,30 +1548,49 @@ } } } + + #aa_log "already_logged_in $already_logged_in" if {!$already_logged_in} { # # The user is not logged in via cookies, check first - # available user_id. If this dies not exist, perform login + # available user_id. If this does not exist, perform login # + #aa_log "not logged in, check $user_info" + if {[dict exists $user_info user_id] && [dict exists $user_info address] } { set user_id [dict get $user_info user_id] if {$user_id ne 0} { - aa_log "::acs::test::set_user set logindata" + #aa_log "::acs::test::set_user set logindata via nsv" + set address [dict get $user_info address] + ad_try { + set peeraddr [ns_addrbyhost $address] + } on error {errorMsg} { + set peeraddr $address + } + set address $peeraddr nsv_set aa_test logindata \ [list \ - peeraddr [dict get $user_info address] \ - user_id [dict get $user_info user_id]] + peeraddr $address \ + user_id $user_id] dict set session login via_logindata } else { dict set session login none } + } elseif {[dict exists $session cookies]} { + # + # We have cookies, but are not logged in. Do NOT automatically log in. + # + dict set session login none } else { - aa_log "::acs::test::set_user perform login with $user_info" - foreach {att value} [::acs::test::login $user_info] { - dict set session $att $value - } + # + # No cookies, log automatically in. + # + #aa_log "::acs::test::set_user perform login with $user_info" + set d [::acs::test::login $user_info] + #aa_log "::acs::test::set_user perform login returned session [dict get $d session]" + dict set session cookies [dict get $d session cookies] dict set session login via_login } } @@ -1372,12 +1606,12 @@ @param user_info dict containing at least email, last_name, username and password } { - aa_log $user_info + #aa_log "acs::test::login with user_info $user_info" set d [acs::test::http -user_id 0 /register/] acs::test::reply_has_status_code $d 200 set form [acs::test::get_form [dict get $d body ] {//form[@id='login']}] - set fields [dict get $form fields] + set fields [acs::test::form_get_fields $form] if {[dict exists $fields email]} { aa_log "login via email [dict get $user_info email]" dict set fields email [dict get $user_info email] @@ -1386,44 +1620,97 @@ dict set fields username [dict get $user_info username] } dict set fields password [dict get $user_info password] + set form [acs::test::form_set_fields $form $fields] - set d [::acs::test::form_reply \ - -user_id 0 \ - -url [dict get $form @action] \ - $fields] + set d [::acs::test::form_reply -user_id 0 -form $form] acs::test::reply_has_status_code $d 302 + aa_test_start return $d } ad_proc -public ::acs::test::logout { - -session:required + -last_request:required } { Logout from the current web session - @param session reply dict containing cookies + @param last_request reply dict containing cookies } { - set d [acs::test::http -session $session /register/logout] + set d [acs::test::http -last_request $last_request /register/logout] acs::test::reply_has_status_code $d 302 + aa_test_end + return $d } + + ad_proc -public ::acs::test::get_url_from_location { + dict + } { + Determine the URL based on the location field provided from + the result dict (as returned from acs::test::http). + + @param dict dict containing an ns_set called headers + @see acs::test::http + } { + set location [ns_set iget [dict get $dict headers] Location ""] + if {$location ne ""} { + set urlDict [ns_parseurl $location] + #aa_log "parse URL '$location' => $urlDict" + if {[dict get $urlDict tail] ne ""} { + set url [dict get $urlDict path]/[dict get $urlDict tail] + } else { + set url [dict get $urlDict path]/ + } + if {[dict exists $urlDict query]} { + set query [dict get $urlDict query] + if {$query ne ""} { + append url "?$query" + } + } + } else { + set url "" + } + return $url + } + + ad_proc -public ::acs::test::confirm_email { + -user_id:required + } { + Confirms user email + } { + # Call the confirmation URL and check response + set token [auth::get_user_secret_token -user_id $user_id] + set to_addr [party::get -party_id $user_id -element email] + set confirmation_url [export_vars -base "/register/email-confirm" { token user_id }] + set d [acs::test::http $confirmation_url] + acs::test::reply_has_status_code $d 200 + } + ad_proc -public ::acs::test::visualize_control_chars {lines} { Quotes and therefore makes visible control chars in input lines } { - set output $lines - regsub -all {\\} $output {\\\\} output - regsub -all {\r} $output {\\r} output - regsub -all {\n} $output "\\n\n" output - return $output + return [string map {\\ \\\\ \r \\r \n "\\n\n"} $lines] } ad_proc -public ::acs::test::dom_html {var html body} { + Parses HTML into a tDOM object and executes some code. + + @param var the variable name that body can refer to as + documentElement of the document (e.g. "root"). + @param html the markup to be parsed. + @param body a Tcl script executed in the caller scope that can + assume the document to be parsed and be available + in "var". } { upvar $var root - dom parse -html $html doc + try { + dom parse -html -- $html doc + } on error {errorMsg} { + ns_log error "Failed to parse the following HTML text with message: $errorMsg\n$html" + } $doc documentElement root - uplevel $body + uplevel 1 $body } ad_proc -public get_form {body xpath} { @@ -1444,11 +1731,52 @@ return $form_data } + ad_proc -public form_get_fields {form} { + + Get the fields from a form. + + @form form dict + @see acs::test::get_form + + @author Gustaf Neumann + } { + return [dict get $form fields] + } + + ad_proc -public form_set_fields {form fields} { + + Set the fields in a form. + + @form form dict + @fields fields in form of attribute/value pairs + + @see acs::test::get_form + + @author Gustaf Neumann + } { + dict set form fields $fields + return $form + } + + ad_proc -public form_is_empty {form} { + + Check, if the form is empty + + @form form dict + + @see acs::test::get_form + + @author Gustaf Neumann + } { + return [expr {[llength $form] == 0}] + } + + ad_proc -public follow_link { + -last_request:required {-user_id 0} {-base /} {-label ""} - {-html:required} } { Follow the first provided label and return the page info. @@ -1457,7 +1785,27 @@ @author Gustaf Neumann } { + set href [find_link \ + -last_request $last_request \ + -user_id $user_id \ + -base $base \ + -label $label] + return [http -last_request $last_request -user_id $user_id $href] + } + + ad_proc -public find_link { + -last_request:required + {-user_id 0} + {-base /} + {-label ""} + } { + + Find the first link based on the provided label and return the href. + + @author Gustaf Neumann + } { set href "" + set html [dict get $last_request body] acs::test::dom_html root $html { foreach a [$root selectNodes //a] { set link_label [string trim [$a text]] @@ -1477,14 +1825,14 @@ # aa_log "a TEXT '[$a asHTML]'" } } - aa_true "Link label for '$label' is not empty: '$href'" {$href ne ""} + aa_true "href '$href' of link with label '$label' is not empty (Details)" \ + {$href ne ""} if {![string match "/*" $href]} { set href $base/$href } - return [http -user_id $user_id $href] + return $href } - ad_proc -private detail_link {dict} { Create a detail link, which is useful for web-requests, to @@ -1513,27 +1861,27 @@ } { set result [string match *$string* [dict get $dict body]] if {$result} { - aa_true "${prefix} Reply contains $string" $result + aa_true "${prefix}Reply contains $string" $result } else { - aa_true "${prefix} Reply contains $string (Details)" $result + aa_true "${prefix}Reply contains $string (Details)" $result } return $result } ad_proc -public reply_contains_no {{-prefix ""} dict string} { Convenience function for test cases to check, whether the - resulting page does not contains the given string. + resulting page does not contain the given string. @param prefix prefix for logging @param dict request reply dict, containing at least the request body @param string string to be checked on the page } { set result [string match *$string* [dict get $dict body]] if {$result} { - aa_false "${prefix} Reply contains no $string (Details)" $result + aa_false "${prefix}Reply contains no $string (Details)" $result } else { - aa_false "${prefix} Reply contains no $string" $result + aa_false "${prefix}Reply contains no $string" $result } return [expr {!$result}] } @@ -1550,9 +1898,9 @@ } { set result [expr {[dict get $dict status] == $status_code}] if {$result} { - aa_true "${prefix} Reply has status code $status_code" $result + aa_true "${prefix}Reply has status code $status_code" $result } else { - aa_true "${prefix} Reply expected status code $status_code but got [dict get $dict status] (Details)" $result + aa_true "${prefix}Reply expected status code $status_code but got [dict get $dict status] (Details)" $result } return $result } @@ -1564,7 +1912,7 @@ # # All procs in this namespace have the signature # root xpath - # where root is a dom-node and xpath a an XPath expression. + # where "root" is a DOM-node and "xpath" is an XPath expression. # ad_proc -public get_text {root xpath} { Get a text element from tdom via XPath expression. @@ -1588,15 +1936,15 @@ ad_proc -public non_empty {node selectors} { - Test if provided selectors return non-empty results + Test if provided selectors return nonempty results } { # # if we have no node, use as default the root in the parent - # enviromnent + # environment # if {$node eq ""} { - set node [uplevel {set root}] + set node [uplevel 1 {set root}] } foreach q $selectors { try { @@ -1612,7 +1960,7 @@ ad_proc -public equals {node pairs} { Test whether provided selectors (first element of the pair) - return the specificed results (second element of the pair). + return the specified results (second element of the pair). } { foreach {q value} $pairs { @@ -1638,12 +1986,14 @@ @author Gustaf Neumann } { set d {} - set form [$node selectNodes $xpath] - if {[llength $form] > 1} { + set formNodes [$node selectNodes $xpath] + if {[llength $formNodes] > 1} { error "XPath expression must point to at most one HTML form" } else { - foreach form [$node selectNodes $xpath] { + #aa_log "xpath::get_form has form nodes '$formNodes'" + foreach form $formNodes { foreach att [$node selectNodes $xpath/@*] { + #aa_log "xpath::get_form form '$form' has attribute '$att'" dict set d @[lindex $att 0] [lindex $att 1] } dict set d fields [::acs::test::xpath::get_form_values $node $xpath] @@ -1652,6 +2002,14 @@ return $d } + ad_proc -private get_name_attribute {node xpath} { + if {![$node hasAttribute name]} { + aa_log_result warning "input field $xpath has no 'name' attribute (ignored): " \ + "
[ns_quotehtml [$node asHTML]]
" + return "" + } + return [$node getAttribute name] + } ad_proc -public get_form_values {node xpath} { @@ -1663,7 +2021,22 @@ } { set values {} foreach n [$node selectNodes $xpath//input] { - set name [$n getAttribute name] + set name [get_name_attribute $n $xpath//input] + if {$name eq ""} continue + + # Disabled attributes are not sent together with the form + # on submit, so we do not fetch them. + if {[$n hasAttribute disabled]} { + continue + } + + # Do not consider unchecked radio buttons or checkboxes as + # values + if {[$n getAttribute type ""] in {"radio" "checkbox"} && + ![$n hasAttribute checked]} { + continue + } + #ns_log notice "aa_xpath::get_form_values from $className input node $n name $name:" if {[$n hasAttribute value]} { set value [$n getAttribute value] @@ -1673,13 +2046,29 @@ lappend values $name $value } foreach n [$node selectNodes $xpath//textarea] { - set name [$n getAttribute name] + set name [get_name_attribute $n $xpath//textarea] + if {$name eq ""} continue + + # Disabled attributes are not sent together with the form + # on submit, so we do not fetch them. + if {[$n hasAttribute disabled]} { + continue + } + #ns_log notice "aa_xpath::get_form_values from $className textarea node $n name $name:" set value [$n text] lappend values $name $value } foreach n [$node selectNodes $xpath//select/option\[@selected='selected'\]] { - set name [[$n parentNode] getAttribute name] + set name [get_name_attribute [$n parentNode] $xpath//option/..] + if {$name eq ""} continue + + # Disabled attributes are not sent together with the form + # on submit, so we do not fetch them. + if {[$n hasAttribute disabled]} { + continue + } + set value [$n getAttribute value] lappend values $name $value } @@ -1691,18 +2080,54 @@ namespace eval acs::test::user { ad_proc ::acs::test::user::create { - {-user_id ""} {-admin:boolean} + {-email ""} + {-locale en_US} + {-password ""} + {-user_id ""} } { - Create a test user with random email and password for testing + Create a test user with random email and password for testing. + If an email is passed in and the party identified by the + password exists, the user_id of this party is returned in the + dict. - @param admin Provide this switch to make the user site-wide admin + @param user_id user_id for the user to be created + @param email email for the user to be created + @param password password for the user to be created + @param admin provide this switch to make the user site-wide admin + @param locale locale for the user to be created + @return The user_info dict returned by auth::create_user. Contains the additional keys email and password. } { - set username "__test_user_[ad_generate_random_string]" - set email "${username}@test.test" - set password [ad_generate_random_string] + # + # Currently, we are not able to reuse the testing account + # based on email, since a later login attempt for that account + # fails, since we have no cookie yet, and the testing + # authority does not allow logins via /login. + # + if {$email ne "" && 0} { + set party_info [party::get -email $email] + if {[llength $party_info] > 0} { + # + # We have such a party already. Return the usual + # elements like on new creation. + # + set d [acs_user::get -user_id [dict get $party_info party_id]] + dict set user_info user_id [dict get $party_info party_id] + dict set user_info password [dict get $d password] + dict set user_info email [dict get $d email] + dict set user_info first_names [dict get $d first_names] + dict set user_info last_name [dict get $d last_name] + return $user_info + } + } + if {$password eq ""} { + set password [ad_generate_random_string] + } + set username "__test_user_[ad_generate_random_string]" + set email "$username@test.test" + set first_names [ad_generate_random_string] set last_name [ad_generate_random_string] @@ -1716,7 +2141,10 @@ -secret_question [ad_generate_random_string] \ -secret_answer [ad_generate_random_string] \ -authority_id [auth::authority::get_id -short_name "acs_testing"]] - + if {![dict exists $user_info user_id]} { + aa_error "invalid USER_INFO (does not contain user_id): $user_info" + } + lang::user::set_locale -user_id [dict get $user_info user_id] $locale if { [dict get $user_info creation_status] ne "ok" } { # Could not create user error "Could not create test user with username=$username user_info=[array get user_info]" @@ -1727,7 +2155,8 @@ dict set user_info first_names $first_names dict set user_info last_name $last_name - aa_log "Created user with email='$email' and password='$password'" + #aa_log "Created user with email='$email' and password='$password'" + aa_log "Created user with email='$email'" if { $admin_p } { aa_log "Making user site-wide admin" @@ -1742,9 +2171,28 @@ ad_proc ::acs::test::user::delete { {-user_id:required} + {-delete_created_acs_objects:boolean false} } { Remove a test user. } { + # + # Delete modifying user info, since otherwise we cannot delete + # the user_id. The modifying user is e.g. propagated to parent + # objss when modifying a page in the content reposistory. + # + db_dml unset_modifying_user { + UPDATE acs_objects + SET modifying_user = NULL + where modifying_user = :user_id + } + # + # If desired, delete the created acs_objects of this user. + # + if {$delete_created_acs_objects_p} { + db_dml unset_modifying_user { + delete from acs_objects where creation_user = :user_id + } + } acs_user::delete \ -user_id $user_id \ -permanent @@ -1753,7 +2201,6 @@ - namespace eval aa_test {} ad_proc -public aa_test::xml_report_dir {} { @@ -1885,7 +2332,7 @@ set report_dir [aa_test::xml_report_dir] if { [file isdirectory $report_dir] } { - set hostname [exec hostname] + set hostname [exec [::util::which hostname]] set server [ns_info server] set file_path "$report_dir/${hostname}-${server}-testreport.xml" @@ -1911,7 +2358,7 @@ set root_node [xml_doc_get_first_node $tree] - # Get the total test case cound + # Get the total test case count set testcase_count_node [xml_node_get_children_by_name $root_node testcase_count] set test(testcase_count) [xml_node_get_content $testcase_count_node] @@ -1932,11 +2379,10 @@ set test(testcase_failure) [array get testcase_failure] } - ad_proc -public aa_get_first_url { {-package_key:required} } { - Procedure for getting the url of a mounted package with the + Procedure for getting the URL of a mounted package with the package_key. It uses the first instance that it founds. This is useful for tclwebtest tests. } { @@ -1961,13 +2407,111 @@ @param explanation An explanation accompanying the response. } { if {$response} { - aa_log_result "pass" $explanation + aa_log_result "pass" "[aa_indent] $explanation" } else { - aa_log_result "fail" $explanation + aa_log_result "fail" "[aa_indent] $explanation" } } -ad_proc -public aa_selenium_init {} { +ad_proc -private aa_used_application_memory {} { + + Return the currently used application memory. This function + depends on the usage of TCMalloc from Google Performance Tools. + +} { + if {[::acs::icanuse "ns_info meminfo"]} { + set mem_info [ns_info meminfo] + dict with mem_info { + # check for a line looking in the TCMalloc result like: + # + # MALLOC: 2531634144 ( 2414.4 MiB) Bytes in use by application + # + if {[info exists stats] && [regexp {\nMALLOC:\s+(\d+)\s} $stats . bytes]} { + set old_value [nsv_set -reset aa_test application_memory $bytes] + if {$old_value ne ""} { + return [list current $bytes diff [expr {$bytes - $old_value}]] + } + } + } + } +} + +ad_proc -public aa_check_leftovers {-silent:boolean {msg final}} { + # + # Perform cleanup tests to check for object/command leaks in + # either the called functions or in the test itself. + # +} { + if {[namespace which ::xo::at_cleanup] ne ""} { + ::xo::at_cleanup + } + + set domNodes [list {*}[info commands domNode0*] {*}[info commands domDoc0x*]] + set xotclObjs [::xotcl::Object info instances -closure] + set nxObjs [::nx::Object info instances -closure] + set tmpObjs [info commands ::nsf::__#*] + set nsSets [expr {[acs::icanuse "ns_set stats"] ? [list [ns_set stats]] : [llength [ns_set list]]}] + + dict set stats tdom [llength $domNodes] + dict set stats nssets [llength $nsSets] + dict set stats xotcl [llength $xotclObjs] + dict set stats nx [llength $nxObjs] + dict set stats tmpobjs [llength $tmpObjs] + + dict with stats { + aa_equals "$msg leftover temp objects" $tmpobjs 0 + if {$tmpobjs > 0} { + foreach obj $tmpObjs { + set isXotcl [::nsf::dispatch $obj ::nsf::methods::object::info::hastype ::xotcl::Object] + set isNx [::nsf::dispatch $obj ::nsf::methods::object::info::hastype ::nx::Object] + aa_log obj $obj (isXotcl $isXotcl isNx $isNx) + aa_log 
[$obj serialize]
+ $obj destroy + } + } + aa_equals "$msg leftover tdom cmds" $tdom 0 + foreach n $domNodes { + if {[string match domDoc0x* $n]} { + aa_log node:$n\n
[ns_quotehtml [$n asXML -indent 4]]
+ $n delete + } + } + if {$silent_p} { + aa_log "$msg XOTcl objects: $xotcl nx objects: $nx nssets: $nssets" + set mem_info [aa_used_application_memory] + if {$mem_info ne ""} { + dict with mem_info { + aa_log "current memory: [format %.6f [expr {$current/1000000.0}]] MB " \ + "difference to begin of this case: [format %.3f [expr {$diff/1000.0}]] KB" + } + } + } + } +} + +ad_proc -public aa_silence_log_entries { + -severities:required + code +} { + + Silence expected messages in the system log. The proc deactivates + the specified severity levels during the code in the last argument + is executed. After it has finished, the severity levels are reset + to their previous values. + +} { + set old_severity_values [lmap severity $severities {ns_logctl severity $severity 0}] + try { + set result [uplevel $code] + } finally { + foreach severity $severities old_severity_value $old_severity_values { + ns_logctl severity $severity $old_severity_value + } + } + return $result +} + +ad_proc -private aa_selenium_init {} { Setup a global Selenium RC server connection @return true is everything is ok, false if there was any error @@ -2000,7 +2544,7 @@ -package_key acs-automated-testing \ -parameter "SeleniumRcBrowsers" \ -default "*firefox"] - set success_p [expr {![catch {Se init $server_url $server_port ${browsers} [ad_url]} errmsg]}] + set success_p [expr {![catch {::acs::test::selenium::Se init $server_url $server_port ${browsers} [ad_url]} errmsg]}] if {!$success_p} { ns_log error [ad_log_stack_trace] } @@ -2012,7 +2556,7 @@ "selenium" \ "Init Class for Selenium Remote Control" \ {aa_selenium_init} \ - {catch {Se stop} errmsg} + {catch {::acs::test::selenium::Se stop} errmsg} # # Local variables: