############################################################################## # # Copyright 2001, OpenACS, Peter Harper. # # This file is part of acs-automated-testing # ############################################################################## 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: aa-test-procs.tcl,v 1.79.2.12 2019/06/11 19:00:23 gustafn Exp $ } # 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 ""} { nsv_lappend aa_test categories "selenium" } else { nsv_lappend aa_test exclusion_categories "selenium" } } 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 an 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 } { 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 } { 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 {$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 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\) $new_body " 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] } } ad_proc -public aa_unstub { proc_name } { @author Peter Harper @creation-date 24 July 2001 } { aa_proc_copy ${proc_name}_unstubbed $proc_name return } ad_proc -public aa_register_init_class { init_class_id init_class_desc constructor destructor } { Registers a 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. An initialization constructor is called once before running a set of testcases, and the destructor 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 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. 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 destructor to unmount the package. @author Peter Harper @creation-date 04 November 2001 @param init_class_id Unique string to identify the init class @param init_class_desc Longer description of the init class @param constructor Tcl code block to run to setup the init class @param destructor Tcl code block to tear down the init class } { # # Work out the package key # set package_root [file join $::acs::rootdir packages] set package_rel [string replace [info script] \ 0 [string length $package_root]] if {![info exists package_key]} { 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 } # # 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 {} " aa_log \"Running \\\"$init_class_id\\\" initialization class constructor\" $constructor " 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 } $destructor " } ad_proc -public aa_register_component { 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 } { # # Work out the package key # set package_root [file join $::acs::rootdir 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 } # # 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 } ad_proc -public aa_call_component { 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 } { 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] } } # # If the component exists, execute the body code in the testcases stack # level. # if {$body ne ""} { 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 { {-libraries {}} {-cats {}} {-error_level "error"} {-bugs {}} {-procs {}} {-urls {}} {-init_classes {}} {-on_error {}} testcase_id testcase_desc args } { 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:
aa_export_vars {package_id item_id} set package_id 23 set item_id 109} { uplevel " foreach v $args { upvar \$v \$v uplevel 1 \"lappend _aa_export \$v\" } " } ad_proc -public aa_runseries { {-stress 0} {-security_risk 0} -quiet:boolean {-testcase_id ""} {by_package_keys ""} {by_category ""} } { Runs a series of testcases. 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 set aa_run_quietly_p $quiet_p # # Work out the list of initialization classes. # set testcase_ids {} if {$testcase_id ne ""} { lappend testcase_ids $testcase_id foreach testcase [nsv_get aa_test cases] { if {$testcase_id == [lindex $testcase 0]} { set package_key [lindex $testcase 3] set init_classes [lindex $testcase 5] foreach init_class $init_classes { set classes([list $package_key $init_class]) 1 } } } } else { foreach testcase [nsv_get aa_test cases] { set testcase_id [lindex $testcase 0] set package_key [lindex $testcase 3] set categories [lindex $testcase 4] set init_classes [lindex $testcase 5] # try to disqualify the test case # check if package key belongs to the ones we are testing if { $by_package_keys ne "" && $package_key ni $by_package_keys } { continue } # is it the wrong category? if { $by_category ne "" && $by_category ni $categories } { continue } # if we don't want stress, then the test must not be stress if { ! $stress && "stress" in $categories } { continue } # if we don't want security risks, then the test must not be stress if { ! $security_risk && "security_risk" in $categories } { continue } # we made it through the filters, so add the test case lappend testcase_ids $testcase_id foreach init_class $init_classes { set classes([list $package_key $init_class]) 1 } } } # # Run each initialization script. Keep a list of the exported variables # by each initialization script so each testcase (and destructor) can # correctly upvar to gain visibility of them. # if {[info exists classes]} { 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] _${package_key}__i_$init_class set _aa_exports([list $package_key $init_class]) $_aa_export } } set aa_in_init_class "" # # Run each testcase # foreach testcase_id $testcase_ids { aa_run_testcase $testcase_id } # # Run each initialization destructor script. # 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] _${package_key}__d_$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 { 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 # # Lookup the testcase definition. # set testcase_bodys {} foreach testcase [nsv_get aa_test cases] { if {$testcase_id == [lindex $testcase 0]} { set testcase_file [lindex $testcase 2] set package_key [lindex $testcase 3] set testcase_cats [lindex $testcase 4] 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 } } if {[llength $testcase_bodys] == 0} { return } # # Create any file-wide stubs. # if {[nsv_exists aa_file_wide_stubs "$testcase_file"]} { foreach stub_def [nsv_get aa_file_wide_stubs "$testcase_file"] { aa_stub [lindex $stub_def 0] [lindex $stub_def 1] } } # # 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 ns_log debug "aa_run_testcase: Running testcase $testcase_id" set catch_val [catch _${package_key}__$testcase_id msg] if {$catch_val} { aa_log_result "fail" "$testcase_id: Error calling testcase function _${package_key}__$testcase_id: $msg" } # # Unstub any stubbed functions # foreach stub_name $aa_stub_names { aa_unstub $stub_name } set aa_stub_names {} aa_log_final $aa_testcase_passes $aa_testcase_fails unset aa_testcase_id } ad_proc -public aa_equals { affirm_name affirm_actual affirm_value } { Tests that the affirm_actual is equal to affirm_value.
Call this function within a testcase, stub or component. @return True if the affirmation passed, false otherwise. @author Peter Harper @creation-date 24 July 2001 } { global aa_testcase_id global aa_package_key if {$affirm_actual eq $affirm_value} { aa_log_result "pass" [subst {[aa_indent] $affirm_name, actual = "$affirm_actual"}] return 1 } else { aa_log_result "fail" [subst {[aa_indent] $affirm_name, actual = "$affirm_actual", expected = "$affirm_value"}] return 0 } } ad_proc -public aa_true { 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. @author Peter Harper @creation-date 24 July 2001 } { set result [uplevel 1 [list expr $affirm_expr]] if {$affirm_expr in {0 1 t f true false}} { set expr "" } else { set expr [subst {"$affirm_expr" }] } if { $result } { aa_log_result "pass" "[aa_indent] $affirm_name: $expr true" return 1 } else { aa_log_result "fail" "[aa_indent] $affirm_name: $expr false" return 0 } } ad_proc -public aa_false { 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 } { global aa_testcase_id global aa_package_key set result [uplevel 1 [list expr $affirm_expr]] if {!$result} { aa_log_result "pass" [subst {[aa_indent] $affirm_name: "$affirm_expr" false}] return 1 } else { aa_log_result "fail" [subst {[aa_indent] $affirm_name: "$affirm_expr" true}] return 0 } } ad_proc -public aa_section { log_notes } { Writes a log message indicating a new section to the log file. } { aa_log_result "sect" $log_notes } ad_proc -public aa_log { 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 } { #global aa_testcase_id #global aa_package_key # # When aa_run_quietly_p exists, we run inside the testing # environment. # if {[info exists ::aa_run_quietly_p]} { if {$::aa_run_quietly_p} { return } aa_log_result "log" "[aa_indent] $log_notes" } else { # # Use plain ns_log reporting # ns_log notice "aa_log: $log_notes" } } ad_proc -public aa_error { 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
} {
aa_log_result "fail" $error_notes
}
ad_proc -public aa_log_result {
test_result
test_notes
} {
@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
}
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
# 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) \
[list $test_result $test_notes]
return
}
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
} elseif {$test_result eq "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"
}
}
} elseif {$test_result ne "sect"} {
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
} {
@author Peter Harper
@creation-date 24 July 2001
} {
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 {}
}
ad_proc -public aa_run_with_teardown {
{-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.
@param test_code Tcl code that sets up the test case and executes tests
@param teardown_code Tcl code that tears down database data etc. that needs to execute
after testing even if error is thrown.
@param rollback If specified, any db transactions in test_code will be rolled back.
@author Peter Marklund
} {
if { $rollback_p } {
set test_code "
set errmsg {}
db_transaction {
aa_start_rollback_block
$test_code
aa_end_rollback_block
error \"rollback tests\"
} on_error {
aa_end_rollback_block
}
aa_execute_rollback_tests
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_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_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 { $error_text ne "" } {
error $error_text
}
}
ad_proc -private aa_start_rollback_block {} {
Start a block of code that is to be rolled back in the db
@author Peter Marklund
} {
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
@author Peter Marklund
} {
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.
@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
}
}
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.
@author Peter Marklund
} {
global aa_rollback_test_statements
lappend aa_rollback_test_statements $args
}
ad_proc -private aa_execute_rollback_tests {} {
Execute all test statements from a rollback block.
@author Peter Marklund
} {
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] } {
unset aa_rollback_test_statements
}
}
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 \n[ns_quotehtml $body]
"
}
aa_log $log_line
#
# Run actual request
#
try {
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
}
}
} finally {
#
# always reset after the reqest 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"
}
}
}
foreach cookie_name [dict keys $cookie_dict] {
lappend cookies $cookie_name=[dict get $cookie_dict $cookie_name]
}
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 {
{-session ""}
user_info
} {
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.
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
#
if {[dict exists $session cookies]} {
#aa_log "session has cookies '[dict get $session cookies]'"
foreach cookie [split [dict get $session cookies] ";"] {
lassign [split [string trim $cookie] =] name value
#aa_log "session has cookie $cookie // NAME '$name' VALUE '$value'"
if {$name in {ad_user_login ad_user_login_secure} && $value ne "\"\""} {
aa_log "user is already logged in via cookie $name"
set already_logged_in 1
dict set session login via_cookie
break
}
}
}
if {!$already_logged_in} {
#
# The user is not logged in via cookies, check first
# available user_id. If this dies 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 via nsv"
nsv_set aa_test logindata \
[list \
peeraddr [dict get $user_info address] \
user_id [dict get $user_info 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 {
#
# 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
}
}
return $session
}
ad_proc -public ::acs::test::login {
user_info
} {
Login (register operation) in a web session
@param user_info dict containing at least
email, last_name, username and password
} {
#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 [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]
} else {
aa_log "login via username [dict get $user_info username]"
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 -form $form]
acs::test::reply_has_status_code $d 302
return $d
}
ad_proc -public ::acs::test::logout {
-last_request:required
} {
Logout from the current web session
@param session reply dict containing cookies
} {
set d [acs::test::http -last_request $last_request /register/logout]
acs::test::reply_has_status_code $d 302
return $d
}
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
}
ad_proc -public ::acs::test::dom_html {var html body} {
} {
upvar $var root
dom parse -html $html doc
$doc documentElement root
uplevel $body
}
ad_proc -public get_form {body xpath} {
Locate the HTML forms matching the XPath expression and
retrieve its HTML attributes and the formfields in form of a
Tcl dict. This is a convenience function, combining
acs::test::dom_html and ::acs::test::xpath::get_form.
@return Tcl dict with form attributes (starting with "@" and fields)
@see acs::test::dom_html ::acs::test::xpath::get_form
@author Gustaf Neumann
} {
acs::test::dom_html root $body {
set form_data [::acs::test::xpath::get_form $root $xpath]
}
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 ""}
} {
Follow the first provided label and return the page info.
Probably, we want as well other mechanisms to locate the
anchor element later.
@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]]
if {$label eq $link_label} {
set href [$a getAttribute href]
break
}
#
# There is something weird in tDOM: without the
# "string trim" we see something like
#
# a TEXT 'DD25C9878' = 'DD25C9878' eq 0 77 9
#
# from the statements below.
# set eq [expr {$label eq $link_label}]
# aa_log "a TEXT '$link_label' = '$label' eq $eq [string length $link_label] [string length $label]"
# aa_log "a TEXT '[$a asHTML]'"
}
}
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 -last_request $last_request -user_id $user_id $href]
}
ad_proc -private detail_link {dict} {
Create a detail link, which is useful for web-requests, to
inspect the result in case a test fails.
Missing: cleanup, e.g. after a couple of days, or when the
testcase is executed again (for that we would need testcase_id
and package_key, that we do not want to pass around)
} {
set nonce REPLY-[clock clicks -microseconds].html
set F [open $::acs::rootdir/packages/acs-automated-testing/www/$nonce w]
puts $F [dict get $dict body]
close $F
return /test/$nonce
}
ad_proc -public reply_contains {{-prefix ""} dict string} {
Convenience function for test cases to check, whether the
resulting page contains 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_true "${prefix}Reply contains $string" $result
} else {
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 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
} else {
aa_false "${prefix}Reply contains no $string" $result
}
return [expr {!$result}]
}
ad_proc -public reply_has_status_code {{-prefix ""} dict status_code} {
Convenience function for test cases to check, whether the
reply has the given status code.
@param prefix prefix for logging
@param dict request reply dict, containing at least the request status
@param status_code expected HTTP status codes
} {
set result [expr {[dict get $dict status] == $status_code}]
if {$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
}
return $result
}
}
namespace eval ::acs::test::xpath {
#
# All procs in this namespace have the signature
# root xpath
# where root is a dom-node and xpath a an XPath expression.
#
ad_proc -public get_text {root xpath} {
Get a text element from tdom via XPath expression.
If the XPath expression matches multiple nodes,
return a list.
} {
set nodes [$root selectNodes $xpath]
switch [llength $nodes] {
0 {set result ""}
1 {set result [$nodes asText]}
default {
set result ""
foreach n $nodes {
lappend result [$n asText]
}
}
}
return $result
}
ad_proc -public non_empty {node selectors} {
Test if provided selectors return non-empty results
} {
#
# if we have no node, use as default the root in the parent
# environment
#
if {$node eq ""} {
set node [uplevel {set root}]
}
foreach q $selectors {
try {
set value [get_text $node $q]
} on error {errorMsg} {
aa_true "XPAth exception during evaluation of selector '$q': $errorMsg" 0
throw {XPATH {xpath triggered exception}} $errorMsg
}
aa_true "XPath $q <$value>:" {$value ne ""}
}
}
ad_proc -public equals {node pairs} {
Test whether provided selectors (first element of the pair)
return the specificed results (second element of the pair).
} {
foreach {q value} $pairs {
try {
set result [get_text $node $q]
} on error {errorMsg} {
aa_true "XPAth exception during evaluation of selector '$q': $errorMsg" 0
throw {XPATH {xpath triggered exception}} $errorMsg
}
aa_equals "XPath $q:" $result $value
}
}
ad_proc -public get_form {node xpath} {
Locate the HTML forms matching the XPath expression and
retrieve its HTML attributes and the formfields in form of a
Tcl dict.
@return Tcl dict with form attributes (keys starting with "@", and entry "fields")
@author Gustaf Neumann
} {
set d {}
set form [$node selectNodes $xpath]
if {[llength $form] > 1} {
error "XPath expression must point to at most one HTML form"
} else {
foreach form [$node selectNodes $xpath] {
foreach att [$node selectNodes $xpath/@*] {
dict set d @[lindex $att 0] [lindex $att 1]
}
dict set d fields [::acs::test::xpath::get_form_values $node $xpath]
}
}
return $d
}
ad_proc -public get_form_values {node xpath} {
Obtain form values (input fields and textareas) in form of a
dict (attribute value pairs). The provided XPath expression
must point to the HTML form containing the values to be
extracted.
} {
set values {}
foreach n [$node selectNodes $xpath//input] {
set name [$n getAttribute name]
#ns_log notice "aa_xpath::get_form_values from $className input node $n name $name:"
if {[$n hasAttribute value]} {
set value [$n getAttribute value]
} else {
set value ""
}
lappend values $name $value
}
foreach n [$node selectNodes $xpath//textarea] {
set name [$n getAttribute name]
#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 value [$n getAttribute value]
lappend values $name $value
}
return $values
}
}
namespace eval acs::test::user {
ad_proc ::acs::test::user::create {
{-admin:boolean}
{-email ""}
{-locale en_US}
{-password ""}
{-user_id ""}
} {
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 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.
} {
if {$email eq ""} {
set email "$username@test.test"
} else {
set party_info [party::get -email $email]
if {[llength $party_info] > 0} {
#
# We have such a party already. For the time being,
# just pick the party_id for the result.
#
dict set user_info user_id [dict get $party_info party_id]
return $user_info
}
}
if {$password eq ""} {
set password [ad_generate_random_string]
}
set username "__test_user_[ad_generate_random_string]"
set first_names [ad_generate_random_string]
set last_name [ad_generate_random_string]
set user_info [auth::create_user \
-user_id $user_id \
-username $username \
-email $email \
-first_names $first_names \
-last_name $last_name \
-password $password \
-secret_question [ad_generate_random_string] \
-secret_answer [ad_generate_random_string] \
-authority_id [auth::authority::get_id -short_name "acs_testing"]]
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]"
}
dict set user_info password $password
dict set user_info email $email
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'"
if { $admin_p } {
aa_log "Making user site-wide admin"
permission::grant -object_id \
[acs_magic_object "security_context_root"] \
-party_id [dict get $user_info user_id] \
-privilege "admin"
}
return $user_info
}
ad_proc ::acs::test::user::delete {
{-user_id:required}
} {
Remove a test user.
} {
acs_user::delete \
-user_id $user_id \
-permanent
}
}
namespace eval aa_test {}
ad_proc -public aa_test::xml_report_dir {} {
Retrieves the XMLReportDir parameter.
@return Returns the value for the XMLReportDir parameter.
} {
return [parameter::get -parameter XMLReportDir]
}
ad_proc -private aa_test::test_file_path {
{-install_file_path:required}
} {
set filename [file tail $install_file_path]
regexp {^(.+)-(.+)-(.+)\.xml$} $filename match hostname server
set test_path [file dirname $install_file_path]/${hostname}-${server}-testreport.xml
return $test_path
}
ad_proc -public aa_test::parse_install_file {
{-path:required}
{-array:required}
} {
Processes the xml report outputted from install.sh for display.
} {
upvar 1 $array service
set tree [xml_parse -persist [template::util::read_file $path]]
set root_node [xml_doc_get_first_node $tree]
foreach entry {
name os dbtype dbversion webserver openacs_cvs_flag adminemail adminpassword
install_begin_epoch install_end_epoch install_end_timestamp num_errors
install_duration install_duration_pretty script_path description
} {
set service($entry) "n/a"
}
set service(path) $path
set service(filename) [file tail $path]
set service(parse_errors) {}
set service(name) [xml_node_get_attribute $root_node "name"]
if { $service(name) eq "" } {
append service(parse_error) "No service name attribute;"
}
foreach child [xml_node_get_children $root_node] {
set info_type [xml_node_get_attribute $child "type"]
if { $info_type eq "" } {
append service(parse_error) "No type on info tag;"
continue
}
set info_type [string map {- _} $info_type]
set info_value [xml_node_get_content $child]
set service($info_type) $info_value
}
if { [string is integer -strict $service(install_begin_epoch)] && [string is integer -strict $service(install_end_epoch)] } {
set service(install_duration) [expr {$service(install_end_epoch) - $service(install_begin_epoch)}]
set service(install_duration_pretty) [util::interval_pretty -seconds $service(install_duration)]
}
# TODO: Not working
set service(admin_login_url) [export_vars -base $service(url)register/ {
{ 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]"
}
ad_proc -private aa_test::get_test_doc {} {
Returns an XML doc with statistics for the most recent test results
on the server.
@author Peter Marklund
} {
# Open XML document
set xml_doc "