Index: openacs-4/packages/acs-automated-testing/acs-automated-testing.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-automated-testing/acs-automated-testing.info,v
diff -u -N -r1.42 -r1.43
--- openacs-4/packages/acs-automated-testing/acs-automated-testing.info 23 Jul 2018 14:08:19 -0000 1.42
+++ openacs-4/packages/acs-automated-testing/acs-automated-testing.info 23 Jul 2018 19:42:34 -0000 1.43
@@ -7,7 +7,7 @@
t
t
-
+
OpenACS
The interface to the automated testing facilities within OpenACS.
2017-08-06
@@ -19,7 +19,7 @@
OpenACS system. Also provides a UI for managing
automatic-rebuild servers as in a test farm.
-
+
Index: openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl,v
diff -u -N -r1.65 -r1.66
--- openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 23 Jul 2018 14:08:19 -0000 1.65
+++ openacs-4/packages/acs-automated-testing/tcl/aa-test-procs.tcl 23 Jul 2018 19:42:34 -0000 1.66
@@ -327,6 +327,7 @@
{-error_level "error"}
{-bugs {}}
{-procs {}}
+ {-urls {}}
{-init_classes {}}
{-on_error {}}
testcase_id
@@ -355,15 +356,18 @@
populator: Creates sample data for future use.
production_safe: Can be used on a live production site, ie for sanity checking or keepalive purposes. Implies: no risk of adding or deleting data; no risk of crashing; minimal cpu/db/net load.
+
@param error_level Force all test failures to this error level. One of
- notice: Informative. Does not indicate an error.
- warning: May indicate an problem. Example: a non-critical bug repro case that hasn't been fixed.
- error: normal error
- metatest: Indicates a problem with the test framework, execution, or reporting. Suggests that current test results may be invalid. Use this for test cases that test the tests. Also used, automatically, for errors sourcing test cases.
+
@param bugs A list of integers correspending to openacs.org bug numbers which relate to this test case.
@param procs A list of OpenACS procs which are tested by this case.
+ @param urls A list of urls (relative to package) tested in web test case
@param on_error Deprecated.
@param init_classes Deprecated.
@@ -1065,91 +1069,151 @@
}
}
-ad_proc -private aa_http {
- {-user_id 0}
- {-method GET}
- {-body}
- {-timeout 10}
- {-headers ""}
- {-prefix ""}
- {-verbose:boolean 1}
- request
-} {
- Run an http request against the actual server
- @author Gustaf Neumann
-} {
- set driverInfo [util_driver_info]
- try {
+
+
+namespace eval acs::test {
+
+ ad_proc -public ::acs::test::form_reply {
+ -user_id:required
+ -url:required
+ {-update {}}
+ form_content
+ } {
+
+ Send a (POST) request to the specified URL based on the
+ provided form_content which has the form of a dict. For
+ convenice the update fields are provided to overload the
+ form_content.
+
+ } {
+ foreach {att value} $update {
+ dict set form_content $att $value
+ }
+ #ns_log notice "final form_content $form_content"
#
- # 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.
+ # Transform the dict into export format. Since export_vars
+ # will skip all names containing a ":", such as
+ # "formbutton:ok", we do this "manually".
#
- set address [ns_conn currentaddr]
- } on error {errorMsg} {
+ set export {}
+ foreach {att value} $form_content {
+ lappend export [ad_urlencode_query $att]=[ad_urlencode_query $value]
+ }
+ set body [join $export &]
+ ns_log notice "body=$body"
#
- # If this fails, fall back to configured value.
+ # Send the POST request
#
- set address [dict get $driverInfo address]
+ return [http \
+ -user_id $user_id \
+ -method POST -body $body \
+ -headers {Content-Type application/x-www-form-urlencoded} \
+ $url]
}
- set extra_args {}
- if {[info exists body]} {
- lappend extra_args -body $body
- }
- if {[llength $headers] > 0} {
- set requestHeaders [ns_set create]
- foreach {tag value} $headers {
- ns_set update $requestHeaders $tag $value
+
+ ad_proc -public ::acs::test::http {
+ {-user_id 0}
+ {-method GET}
+ {-body}
+ {-timeout 10}
+ {-headers ""}
+ {-prefix ""}
+ {-verbose:boolean 1}
+ request
+ } {
+
+ Run an HTTP request against the actual server inside test
+ cases.
+
+ @author Gustaf Neumann
+ } {
+ set driverInfo [util_driver_info]
+ 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]
+ } on error {errorMsg} {
+ #
+ # If this fails, fall back to configured value.
+ #
+ set address [dict get $driverInfo address]
}
- lappend extra_args -headers $requestHeaders
- }
- nsv_set aa_test logindata [list peeraddr $address user_id $user_id]
+ set extra_args {}
+ if {[info exists body]} {
+ lappend extra_args -body $body
+ }
+ if {[llength $headers] > 0} {
+ set requestHeaders [ns_set create]
+ foreach {tag value} $headers {
+ ns_set update $requestHeaders $tag $value
+ }
+ lappend extra_args -headers $requestHeaders
+ }
+ nsv_set aa_test logindata [list peeraddr $address user_id $user_id]
- #
- # Construct a nice log line
- #
- append log_line "${prefix}Run $method $request"
- if {[llength $headers] > 0} {
- append log_line " (headers: $headers)"
- }
- if {[info exists body]} {
- append log_line "\n$body"
- }
- aa_log $log_line
+ #
+ # Construct a nice log line
+ #
+ append log_line "${prefix}Run $method $request"
+ if {[llength $headers] > 0} {
+ append log_line " (headers: $headers)"
+ }
+ if {[info exists body]} {
+ append log_line "\n$body"
+ }
+ aa_log $log_line
- #
- # Run actual request
- #
- try {
- set d [ns_http run \
- -timeout $timeout \
- -method $method \
- {*}$extra_args \
- "http://\[$address\]:[dict get $driverInfo port]/$request"]
- } finally {
#
- # always reset after the reqest the login data nsv
+ # Run actual request
#
- nsv_unset aa_test logindata
+ try {
+ set d [ns_http run \
+ -timeout $timeout \
+ -method $method \
+ {*}$extra_args \
+ "http://\[$address\]:[dict get $driverInfo port]/$request"]
+ } finally {
+ #
+ # always reset after the reqest the login data nsv
+ #
+ nsv_unset 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}]]
+ aa_log "${prefix}$method $request returns [dict get $d status] in ${ms}ms"
+ }
+ return $d
}
- #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}]]
- aa_log "${prefix}$method $request returns [dict get $d status] in ${ms}ms"
+
+ ad_proc -public ::acs::test::dom_html {var html body} {
+ } {
+ upvar $var root
+ dom parse -html $html doc
+ $doc documentElement root
+ uplevel $body
}
- return $d
-}
+
+}
-namespace eval aa_xpath {
+namespace eval ::acs::test::xpath {
- ad_proc -public ::aa_xpath::get_text {root xpath} {
+ #
+ # All procs in this namespace have the 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.
@@ -1168,15 +1232,8 @@
return $result
}
- ad_proc -public ::aa_dom_html {var html body} {
- } {
- upvar $var root
- dom parse -html $html doc
- $doc documentElement root
- uplevel $body
- }
- ad_proc -public ::aa_xpath::non_empty {node selectors} {
+ ad_proc -public non_empty {node selectors} {
Test if provided selectors return non-empty results
} {
#
@@ -1196,7 +1253,7 @@
aa_true "XPath $q <$value>:" {$value ne ""}
}
}
- ad_proc -public ::aa_xpath::equals {node pairs} {
+ ad_proc -public equals {node pairs} {
Test if provided selectors (first element of the pair) return
the specificed results (second element of the pair).
} {
@@ -1212,7 +1269,7 @@
}
}
- ad_proc -public ::aa_xpath::get_form_values {node xpath} {
+ ad_proc -public get_form_values {node xpath} {
return form values (input fields and textareas) in form of a
dict (attribute value pairs). The provided xpath must point to
@@ -1248,46 +1305,69 @@
}
-namespace eval aa_test {}
+namespace eval acs::test::user {
+
+ ad_proc ::acs::test::user::create {
+ {-user_id ""}
+ {-admin:boolean}
+ } {
+ Create a test user with random email and password for testing
-ad_proc -public ::aa_test::form_reply {
- -user_id:required
- -url:required
- {-update {}}
- form_content
-} {
+ @param admin Provide this switch to make the user site-wide admin
+ @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]
+
+ set user_info [auth::create_user \
+ -user_id $user_id \
+ -username $username \
+ -email $email \
+ -first_names [ad_generate_random_string] \
+ -last_name [ad_generate_random_string] \
+ -password $password \
+ -secret_question [ad_generate_random_string] \
+ -secret_answer [ad_generate_random_string]]
+
+ 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
+
+ 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
+ }
- Send a (POST) request to the specified URL based on the
- provided form_content which has the form of a dict. For
- convenice the update fields are provided to overload the
- form_content.
-
-} {
- foreach {att value} $update {
- dict set form_content $att $value
+ ad_proc ::acs::test::user::delete {
+ {-user_id:required}
+ } {
+ Remove a test user.
+ } {
+ acs_user::delete \
+ -user_id $user_id \
+ -permanent
}
- #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".
- #
- set export {}
- foreach {att value} $form_content {
- lappend export [ad_urlencode_query $att]=[ad_urlencode_query $value]
- }
- set body [join $export &]
- ns_log notice "body=$body"
- #
- # Send the POST request
- #
- return [aa_http \
- -user_id $user_id \
- -method POST -body $body \
- -headers {Content-Type application/x-www-form-urlencoded} \
- $url]
}
+
+
+
+namespace eval aa_test {}
+
ad_proc -public aa_test::xml_report_dir {} {
Retrieves the XMLReportDir parameter.
Index: openacs-4/packages/acs-automated-testing/tcl/tclwebtest-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-automated-testing/tcl/tclwebtest-procs.tcl,v
diff -u -N -r1.14 -r1.15
--- openacs-4/packages/acs-automated-testing/tcl/tclwebtest-procs.tcl 11 Jul 2018 10:37:41 -0000 1.14
+++ openacs-4/packages/acs-automated-testing/tcl/tclwebtest-procs.tcl 23 Jul 2018 19:42:34 -0000 1.15
@@ -107,47 +107,16 @@
the additional keys email and password.
@author Peter Marklund
-} {
- set username "__test_user_[ad_generate_random_string]"
- set email "${username}@test.test"
- set password [ad_generate_random_string]
-
- array set user_info [auth::create_user \
- -user_id $user_id \
- -username $username \
- -email $email \
- -first_names [ad_generate_random_string] \
- -last_name [ad_generate_random_string] \
- -password $password \
- -secret_question [ad_generate_random_string] \
- -secret_answer [ad_generate_random_string]]
-
- if { $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]"
- }
-
- set user_info(password) $password
- set user_info(email) $email
-
- 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 $user_info(user_id) -privilege "admin"
- }
-
- return [array get user_info]
+ } {
+ return [acs::test::user::create -user_id $user_id -admin=$admin_p]
}
ad_proc twt::user::delete {
{-user_id:required}
} {
Remove a test user.
} {
- acs_user::delete \
- -user_id $user_id \
- -permanent
+ ::acs::test::user_delete -user_id $user_id
}
ad_proc twt::user::login { email password {username ""}} {
Index: openacs-4/packages/forums/forums.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/forums/forums.info,v
diff -u -N -r1.53 -r1.54
--- openacs-4/packages/forums/forums.info 23 Jul 2018 14:18:11 -0000 1.53
+++ openacs-4/packages/forums/forums.info 23 Jul 2018 19:42:34 -0000 1.54
@@ -9,7 +9,7 @@
f
t
-
+
OpenACS
Online discussion forums.
2017-08-06
@@ -19,14 +19,14 @@
2
#forums.Forums#
-
+
-
+
Index: openacs-4/packages/forums/tcl/test/forums-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/forums/tcl/test/forums-procs.tcl,v
diff -u -N -r1.7 -r1.8
--- openacs-4/packages/forums/tcl/test/forums-procs.tcl 23 Jul 2018 14:18:12 -0000 1.7
+++ openacs-4/packages/forums/tcl/test/forums-procs.tcl 23 Jul 2018 19:42:34 -0000 1.8
@@ -187,32 +187,32 @@
#
# Create a new admin user
#
- set user_info [twt::user::create -admin]
+ set user_info [acs::test::user::create -admin]
set user_id [dict get $user_info user_id]
#
# Get the forums admin page url
#
set forums_page [aa_get_first_url -package_key forums]
- set d [aa_http \
+ set d [acs::test::http \
-user_id $user_id \
$forums_page/admin/forum-new]
aa_equals "Status code valid" [dict get $d status] 200
#
# Get the form specific data (action, method and provided form-fields)
#
- aa_dom_html root [dict get $d body] {
+ acs::test::dom_html root [dict get $d body] {
set n_form [$root selectNodes {//form[@id="forum"]}]
set f_action [lindex [$root selectNodes {//form[@id='forum']/@action}] 0 1]
set f_method [lindex [$root selectNodes {//form[@id='forum']/@method}] 0 1]
- set f_fields [::aa_xpath::get_form_values $root {//form[@id='forum']}]
+ set f_fields [::acs::test::xpath::get_form_values $root {//form[@id='forum']}]
}
#
# Fill in a few values into the form
#
- set d [::aa_test::form_reply \
+ set d [::acs::test::form_reply \
-user_id $user_id \
-url $f_action \
-update [subst {
@@ -239,7 +239,7 @@
forum::delete -forum_id [dict get $f_fields forum_id]
} -teardown_code {
- twt::user::delete -user_id [dict get $user_info user_id]
+ acs::test::user::delete -user_id [dict get $user_info user_id]
}
}
Index: openacs-4/packages/xowf/xowf.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xowf/xowf.info,v
diff -u -N -r1.8 -r1.9
--- openacs-4/packages/xowf/xowf.info 21 May 2018 16:15:00 -0000 1.8
+++ openacs-4/packages/xowf/xowf.info 23 Jul 2018 19:42:34 -0000 1.9
@@ -10,20 +10,20 @@
t
xowf
-
+
Gustaf Neumann
XoWiki Content Flow - an XoWiki based workflow system implementing state-based behavior of wiki pages and forms
2017-08-06
WU Vienna
2
-
-
+
+
-
-
-
+
+
+
t
xowiki
-
+
Gustaf Neumann
A xotcl-based enterprise wiki system with multiple object types
2017-08-06
@@ -55,7 +55,7 @@
BSD-Style
2
-
+
@@ -66,7 +66,7 @@
-
+
Index: openacs-4/packages/xowiki/tcl/test/test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/test/test-procs.tcl,v
diff -u -N -r1.9 -r1.10
--- openacs-4/packages/xowiki/tcl/test/test-procs.tcl 23 Jul 2018 14:12:57 -0000 1.9
+++ openacs-4/packages/xowiki/tcl/test/test-procs.tcl 23 Jul 2018 19:42:34 -0000 1.10
@@ -63,7 +63,7 @@
}
ad_proc -private ::xowiki::test::get_form_values {node className} {
- return [::aa_xpath::get_form_values $node \
+ return [::acs::test::xpath::get_form_values $node \
"//form\[contains(@class,'$className')\]" ]
}
@@ -97,7 +97,7 @@
#
# First check, if test folder exists already.
#
- set d [aa_http -user_id $user_id $instance/$folder_name]
+ set d [acs::test::http -user_id $user_id $instance/$folder_name]
if {[dict get $d status] == 200} {
#
# yes it exists - so delete it
@@ -108,11 +108,11 @@
# create it later again.
#
aa_log "test folder $folder_name exists already, ... delete it (user_id $user_id)"
- set d [aa_http -user_id $user_id $instance/$folder_name?m=delete&return_url=$instance/]
+ set d [acs::test::http -user_id $user_id $instance/$folder_name?m=delete&return_url=$instance/]
aa_equals "Status code valid" [dict get $d status] 302
if {[dict get $d status] == 302} {
set location [::xowiki::test::get_url_from_location $d]
- set d [aa_http -user_id $user_id $location/]
+ set d [acs::test::http -user_id $user_id $location/]
aa_equals "Status code valid" [dict get $d status] 200
}
@@ -127,7 +127,7 @@
# When we try folder creation without being logged in, we
# expect a permission denied error.
#
- set d [aa_http -user_id 0 $instance/$form_name?m=create-new&return_url=$instance/]
+ set d [acs::test::http -user_id 0 $instance/$form_name?m=create-new&return_url=$instance/]
aa_equals "Status code valid" [dict get $d status] 403
::xowiki::test::create_form_page \
@@ -171,7 +171,7 @@
# Create a page under the parent_id
#
aa_log "... create a page in test test folder $parent_id"
- set d [aa_http \
+ set d [acs::test::http \
-user_id $user_id \
$instance/$path/$form_name?m=create-new&parent_id=$parent_id&[export_vars $extra_url_parameter]]
@@ -182,13 +182,13 @@
#
# call edit on the new page
#
- set d [aa_http -user_id $user_id $location]
+ set d [acs::test::http -user_id $user_id $location]
aa_equals "Status code valid" [dict get $d status] 200
set formCSSClass [::xowiki::utility formCSSclass $form_name]
set response [dict get $d body]
- aa_dom_html root $response {
+ acs::test::dom_html root $response {
aa_xpath::non_empty $root [subst {
//form\[contains(@class,'$formCSSClass')\]//button
}]
@@ -211,7 +211,7 @@
aa_true "page has at least 9 fields" { [llength $names] >= 9 }
}
- set d [::aa_test::form_reply \
+ set d [::acs::test::form_reply \
-user_id $user_id \
-url $f_form_action \
-update $update \
@@ -228,7 +228,7 @@
set location [::xowiki::test::get_url_from_location $d]
aa_true "location '$location' is valid" {$location ne ""}
- set d [aa_http -user_id $user_id $location]
+ set d [acs::test::http -user_id $user_id $location]
aa_equals "Status code valid" [dict get $d status] 200
::xo::Package initialize -url $location
@@ -241,7 +241,7 @@
#aa_log "lookup of $folder_name/page -> $item_id"
::xo::db::CrClass get_instance_from_db -item_id $item_id
- set d [aa_http -user_id $user_id \
+ set d [acs::test::http -user_id $user_id \
$instance/admin/set-publish-state?state=ready&revision_id=[$item_id revision_id]]
aa_equals "Status code valid" [dict get $d status] 302
}
@@ -259,14 +259,14 @@
} {
aa_log "... edit page $path"
- set d [aa_http -user_id $user_id $instance/$path?[export_vars $extra_url_parameter]]
+ set d [acs::test::http -user_id $user_id $instance/$path?[export_vars $extra_url_parameter]]
aa_equals "Status code valid" [dict get $d status] 200
#set location [::xowiki::test::get_url_from_location $d]
#aa_true "location '$location' is valid" {$location ne ""}
set response [dict get $d body]
- aa_dom_html root $response {
+ acs::test::dom_html root $response {
set f_id [::xowiki::test::get_object_name $root]
set f_page_name [::xowiki::test::get_form_value $root $f_id _name]
set f_creator [::xowiki::test::get_form_value $root $f_id _creator]
@@ -284,7 +284,7 @@
aa_true "page has at least 9 fields" { [llength $names] >= 9 }
}
- set d [::aa_test::form_reply \
+ set d [::acs::test::form_reply \
-user_id $user_id \
-url $f_form_action \
-update $update \
@@ -296,7 +296,7 @@
}
aa_log "form_content:\n[::xowiki::test::pretty_form_content $form_content]"
- set d [aa_http -user_id $user_id $instance/$path]
+ set d [acs::test::http -user_id $user_id $instance/$path]
aa_equals "Status code valid" [dict get $d status] 200
set response [dict get $d body]
@@ -323,7 +323,7 @@
#
# New form creation happens over the top-level URL
#
- set d [aa_http \
+ set d [acs::test::http \
-user_id $user_id \
$instance/?object_type=::xowiki::Form&edit-new=1&parent_id=$parent_id&return_url=$instance/$path]
@@ -332,7 +332,7 @@
#ns_log notice response=$response
set formCSSClass "margin-form"
- aa_dom_html root $response {
+ acs::test::dom_html root $response {
set selector [subst {string(//form\[contains(@class,'$formCSSClass')\]//input\[@type='submit'\]/@value)}]
set f_submit [$root selectNodes $selector]
@@ -361,7 +361,7 @@
aa_log "empty form_content:\n$[::xowiki::test::pretty_form_content $form_content]"
dict set form_content name $name
- set d [::aa_test::form_reply \
+ set d [::acs::test::form_reply \
-user_id $user_id \
-url $f_form_action \
-update $update \
@@ -391,7 +391,7 @@
aa_log "lookup of form $name -> $item_id"
::xo::db::CrClass get_instance_from_db -item_id $item_id
- set d [aa_http -user_id $user_id \
+ set d [acs::test::http -user_id $user_id \
$instance/admin/set-publish-state?state=ready&revision_id=[$item_id revision_id]]
aa_equals "Status code valid" [dict get $d status] 302
}