Index: openacs-4/etc/install/dotlrn-basic-setup.test =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/dotlrn-basic-setup.test,v diff -u -N -r1.3 -r1.4 --- openacs-4/etc/install/dotlrn-basic-setup.test 11 Oct 2003 22:12:36 -0000 1.3 +++ openacs-4/etc/install/dotlrn-basic-setup.test 12 Oct 2003 01:11:48 -0000 1.4 @@ -3,46 +3,46 @@ # Test Execution START - ::twt::util::log "Login the site wide admin" + ::twt::log "Login the site wide admin" ::twt::user::login_site_wide_admin - ::twt::util::log "Add the site wide admin to dotLRN" + ::twt::log "Add the site wide admin to dotLRN" ::twt::dotlrn::add_site_wide_admin $server_url - ::twt::util::log "Upload users" + ::twt::log "Upload users" ::twt::user::upload_users $server_url - ::twt::util::log "Set up terms" + ::twt::log "Set up terms" ::twt::dotlrn::setup_terms $server_url - ::twt::util::log "Set up departments" + ::twt::log "Set up departments" ::twt::dotlrn::setup_departments $server_url - ::twt::util::log "Set up subjects" + ::twt::log "Set up subjects" ::twt::dotlrn::setup_subjects $server_url - ::twt::util::log "Set up classes" + ::twt::log "Set up classes" ::twt::dotlrn::setup_classes $server_url - ::twt::util::log "Set up communities (i.e. Tennis Club etc.)" + ::twt::log "Set up communities (i.e. Tennis Club etc.)" ::twt::dotlrn::setup_communities $server_url - ::twt::util::log "Add class members, i.e. professors, students and assistants" + ::twt::log "Add class members, i.e. professors, students and assistants" ::twt::class::setup_memberships $server_url - ::twt::util::log "Add class subgroups" + ::twt::log "Add class subgroups" ::twt::class::setup_subgroups $server_url - ::twt::util::log "Add class member applet" + ::twt::log "Add class member applet" ::twt::class::add_member_applets $server_url - ::twt::util::log "Set up class forums - one per class" + ::twt::log "Set up class forums - one per class" ::twt::forums::add_default_forums $server_url - #::twt::util::log "Add forum postings" - #::twt::forums::add_postings + ::twt::log "Add forum postings" + ::twt::forums::add_postings - ::twt::util::log "Add news items - one per class" + ::twt::log "Add news items - one per class" ::twt::news::add_item_to_classes $server_url # Test Execution END Index: openacs-4/etc/install/openacs-install.test =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/openacs-install.test,v diff -u -N -r1.3 -r1.4 --- openacs-4/etc/install/openacs-install.test 11 Oct 2003 17:20:45 -0000 1.3 +++ openacs-4/etc/install/openacs-install.test 12 Oct 2003 01:11:48 -0000 1.4 @@ -4,7 +4,7 @@ # Test Execution START # Request the root page -do_request "$server_url" +::twt::do_request $server_url # Check that database connection is there and configuration is ok assert ![regexp -nocase "At least one misconfiguration was discovered" "[response text]"] @@ -41,6 +41,6 @@ form submit -twt::util::write_response_to_file $install_output_file +::twt::write_response_to_file $install_output_file # Test Execution END Index: openacs-4/etc/install/tcl-api-test.test =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl-api-test.test,v diff -u -N -r1.1 -r1.2 --- openacs-4/etc/install/tcl-api-test.test 8 Sep 2003 05:48:00 -0000 1.1 +++ openacs-4/etc/install/tcl-api-test.test 12 Oct 2003 01:11:48 -0000 1.2 @@ -1,14 +1,14 @@ if { [catch { # Source procedures - source tclwebtest-functions.tcl + source tcl/test-procs.tcl # Test Execution START - # Login the site wide admin - login_site_wide_admin + ::twt::log "Login the site wide admin" + ::twt::user::login_site_wide_admin # Run all tests - do_request "${server_url}/test/admin/rerun?package_key=&category=&view_by=package&quiet=0" + ::twt::do_request "test/admin/rerun?package_key=&category=&view_by=package&quiet=0" # Grep for packages with failed tests if { [regexp -nocase {fail} [response body]] } { Index: openacs-4/etc/install/tcl/admin-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/admin-procs.tcl,v diff -u -N -r1.2 -r1.3 --- openacs-4/etc/install/tcl/admin-procs.tcl 11 Oct 2003 17:20:21 -0000 1.2 +++ openacs-4/etc/install/tcl/admin-procs.tcl 12 Oct 2003 01:10:13 -0000 1.3 @@ -10,7 +10,7 @@ ad_proc ::twt::admin::install_all_packages { server_url } { - do_request "$server_url/acs-admin/apm/packages-install?checked_by_default_p=1" + ::twt::do_request "$server_url/acs-admin/apm/packages-install?checked_by_default_p=1" #assert text "Package Installation" # If there are no new packages to install, just return if { [regexp -nocase {no new packages to install} [response body] match] } { @@ -32,7 +32,7 @@ ad_proc ::twt::admin::add_main_site_folder { server_url folder_name } { - do_request "$server_url/admin/site-map" + ::twt::do_request "$server_url/admin/site-map" link follow ~c "new sub folder" form find ~a new @@ -43,7 +43,7 @@ ad_proc ::twt::admin::mount_main_site_package { server_url folder_name instance_name package_key } { - do_request "$server_url/admin/site-map" + ::twt::do_request "$server_url/admin/site-map" # Follow the link to add a new application at the first matching folder name link find ~c $folder_name @@ -72,15 +72,15 @@ ad_proc ::twt::admin::set_acs_subsite_param { server_url old_parameter_value parameter_value } { - do_request "$server_url/admin/site-map" + ::twt::do_request "$server_url/admin/site-map" link follow ~u {parameter-set\?package%5fid=[0-9]+&package%5fkey=acs%2dsubsite&instance%5fname=Main%20Site} submit_acs_param_internal $old_parameter_value $parameter_value } ad_proc ::twt::admin::set_acs_kernel_param { server_url param_section old_parameter_value parameter_value } { - do_request "$server_url/admin/site-map" + ::twt::do_request "$server_url/admin/site-map" link follow ~u {parameter-set\?package%5fid=[0-9]+&package%5fkey=acs%2dkernel} if { ![string equal $param_section "acs-kernel"] } { Index: openacs-4/etc/install/tcl/class-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/class-procs.tcl,v diff -u -N -r1.3 -r1.4 --- openacs-4/etc/install/tcl/class-procs.tcl 11 Oct 2003 22:10:10 -0000 1.3 +++ openacs-4/etc/install/tcl/class-procs.tcl 12 Oct 2003 01:10:13 -0000 1.4 @@ -6,24 +6,33 @@ namespace eval ::twt::class {} -ad_proc ::twt::class::get_admin_urls { server_url term_pretty_name } { +ad_proc ::twt::class::get_admin_urls { } { Returns a list with the fully qualified URLs of the admin pages of all .LRN classes. } { - set admin_url_base "$server_url/dotlrn/admin/term" - set admin_url_no_term "${admin_url_base}?term_id=-1" + set term_id [::twt::dotlrn::current_term_id] + set page_url [::twt::dotlrn::class_admin_url -term_id $term_id] - # First extract the term_id corresponding to the term_pretty_name - do_request $admin_url_no_term - form find ~n term_form - field find ~n term_id - field select $term_pretty_name - array set term_select_field [field current] - set term_id $term_select_field(value) + set url_pattern {/dotlrn/classes/.*/one-community-admin$} - set admin_url_term "${admin_url_base}?term_id=$term_id" + return [::twt::get_url_list $page_url $url_pattern] +} - return [::twt::util::get_url_list $server_url $admin_url_term {/dotlrn/classes/.*/one-community-admin$}] +ad_proc ::twt::class::get_urls { } { + Returns a list with the fully qualified URLs of the home pages of + all .LRN classes. +} { + # The trick we use here is that we know that class urls are the admin + # URLs minus "one-community-admin" + set url_list [list] + set admin_url_list [get_admin_urls] + + foreach admin_url $admin_url_list { + regexp {^(.*)one-community-admin$} $admin_url match class_url + lappend url_list $class_url + } + + return $url_list } ad_proc ::twt::class::engineering_p { class_url } { @@ -50,10 +59,10 @@ ad_proc ::twt::class::setup_memberships { server_url } { - foreach admin_url [get_admin_urls $server_url "[::twt::dotlrn::current_term_pretty_name]"] { + foreach admin_url [get_admin_urls] { # Admin page for the class - do_request "$admin_url" + ::twt::do_request "$admin_url" # Member management for the class follow_members_link @@ -72,7 +81,7 @@ { [expr $admin_counter < 2 && $admin_counter < [llength $admin_users]] } \ { incr admin_counter } { - set admin_label [::twt::util::get_random_items_from_list $admin_labels 1] + set admin_label [::twt::get_random_items_from_list $admin_labels 1] add_member [lindex $admin_users $admin_counter] $admin_label } } @@ -109,12 +118,12 @@ ad_proc ::twt::class::setup_subgroups { server_url } { - foreach admin_url [get_admin_urls $server_url "[::twt::dotlrn::current_term_pretty_name]"] { + foreach admin_url [get_admin_urls] { foreach {name description policy} [subcommunity_properties_list] { # Admin page of one class - do_request $admin_url + ::twt::do_request $admin_url # Add subcommunity form link follow ~u subcommunity-new @@ -145,14 +154,14 @@ ad_proc ::twt::class::add_member_applets { server_url } { - foreach admin_url [get_admin_urls $server_url "[::twt::dotlrn::current_term_pretty_name]"] { + foreach admin_url [get_admin_urls] { # Only add the members applet to computing classes so that we can # demo adding it to other classes manually if { [regexp -nocase {comput} $admin_url match] } { # Admin page of the class - do_request $admin_url + ::twt::do_request $admin_url # Manage Applets link follow ~u {applets$} Index: openacs-4/etc/install/tcl/config-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/config-procs.tcl,v diff -u -N --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/etc/install/tcl/config-procs.tcl 12 Oct 2003 01:10:13 -0000 1.1 @@ -0,0 +1,63 @@ +# Procs to support testing OpenACS with Tclwebtest. +# +# Procs for getting config info. If those tests were to run +# from within OpenACS some of these procs could go away. +# +# @author Peter Marklund + +namespace eval ::twt::config {} + +#################### +# +# Global variables +# +#################### + +# TODO: put variables in twt namespace + +global __server_url +set __server_url $server_url + +global __admin_last_name +set __admin_last_name $admin_last_name + +global __admin_email +set __admin_email $admin_email + +global __admin_password +set __admin_password $admin_password + +global __url_history +set __url_history [list] + +global __demo_users_password +if { [info exists demo_users_password] } { + set __demo_users_password $demo_users_password +} else { + set __demo_users_password "guest" +} + +global __dotlrn_users_data_file +if { [info exists dotlrn_users_data_file] } { + set __dotlrn_users_data_file $dotlrn_users_data_file +} else { + set __dotlrn_users_data_file users-data.csv +} + +ad_proc ::twt::config::server_url { } { + global __server_url + + return $__server_url +} + +ad_proc ::twt::config::admin_email { } { + global __admin_email + + return $__admin_email +} + +ad_proc ::twt::config::admin_password { } { + global __admin_password + + return $__admin_password +} Index: openacs-4/etc/install/tcl/dotlrn-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/dotlrn-procs.tcl,v diff -u -N -r1.3 -r1.4 --- openacs-4/etc/install/tcl/dotlrn-procs.tcl 11 Oct 2003 22:10:11 -0000 1.3 +++ openacs-4/etc/install/tcl/dotlrn-procs.tcl 12 Oct 2003 01:10:13 -0000 1.4 @@ -9,7 +9,7 @@ ad_proc ::twt::dotlrn::add_term { server_url term_name start_month start_year end_month end_year } { - do_request "$server_url/dotlrn/admin/term-new" + ::twt::do_request "$server_url/dotlrn/admin/term-new" form find ~n add_term field find ~n "term_name" @@ -38,9 +38,27 @@ return "Fall 2003/2004" } +ad_proc ::twt::dotlrn::current_term_id {} { + ::twt::do_request [class_admin_url] + + form find ~n term_form + field find ~n term_id + field select [current_term_pretty_name] + array set term_select_field [field current] + set term_id $term_select_field(value) + + return $term_id +} + +ad_proc ::twt::dotlrn::class_admin_url { + {-term_id "-1"} +} { + return "dotlrn/admin/term?term_id=$term_id" +} + ad_proc ::twt::dotlrn::add_department { server_url pretty_name description external_url } { - do_request "$server_url/dotlrn/admin/department-new" + ::twt::do_request "$server_url/dotlrn/admin/department-new" form find ~n add_department field find ~n "pretty_name" field fill $pretty_name @@ -73,7 +91,7 @@ ad_proc ::twt::dotlrn::add_subject { server_url department_pretty_name pretty_name description } { - do_request "$server_url/dotlrn/admin/class-new" + ::twt::do_request "$server_url/dotlrn/admin/class-new" form find ~n add_class field find ~n "form:id" @@ -111,7 +129,7 @@ ad_proc ::twt::dotlrn::get_class_add_urls { server_url } { - return [::twt::util::get_url_list $server_url "$server_url/dotlrn/admin/classes" "class-instance-new"] + return [::twt::get_url_list "dotlrn/admin/classes" "class-instance-new"] } ad_proc ::twt::dotlrn::setup_classes { server_url } { @@ -124,7 +142,7 @@ foreach link [get_class_add_urls $server_url] { - do_request $link + ::twt::do_request $link form find ~n "add_class_instance" field find field select $term_name @@ -146,7 +164,7 @@ ad_proc ::twt::dotlrn::add_community { server_url name description policy } { - do_request "${server_url}/dotlrn/admin/club-new" + ::twt::do_request "${server_url}/dotlrn/admin/club-new" form find ~n add_club @@ -160,12 +178,23 @@ form submit } +ad_proc ::twt::dotlrn::get_user_admin_url { email } { + Get the .LRN admin URL for a user. This is awkward. If we could + lookup the user_id from email this would be much easier. +} { + ::twt::do_request "dotlrn/admin/users-search?name=$email&form%3Aid=user_search" + + link follow ~u {user} + + return [response url] +} + ad_proc ::twt::dotlrn::add_site_wide_admin { server_url } { global __admin_last_name # Goto users page - do_request "$server_url/dotlrn/admin/users?type=pending" + ::twt::do_request "/dotlrn/admin/users?type=pending" # Goto the community page for the site-wide admin (assuming he's first in the list) link follow ~u {user\?user_id=} Index: openacs-4/etc/install/tcl/forums-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/forums-procs.tcl,v diff -u -N -r1.3 -r1.4 --- openacs-4/etc/install/tcl/forums-procs.tcl 11 Oct 2003 22:10:11 -0000 1.3 +++ openacs-4/etc/install/tcl/forums-procs.tcl 12 Oct 2003 01:10:13 -0000 1.4 @@ -9,10 +9,10 @@ ad_proc ::twt::forums::add_default_forums { server_url } { Adds a general forum to each class. Goes via the class admin pages. } { - foreach admin_url [::twt::class::get_admin_urls $server_url "[::twt::dotlrn::current_term_pretty_name]"] { + foreach admin_url [::twt::class::get_admin_urls] { # Admin page of one class - do_request $admin_url + ::twt::do_request $admin_url # Add forum form link follow ~u forum-new @@ -24,16 +24,75 @@ } ad_proc ::twt::forums::add_postings {} { - global __server_url # Loop over all classes - foreach forum_url [::twt::class::get_urls] { - # Create thread + foreach class_url [::twt::class::get_urls] { - # Enter thread + # Class index page + ::twt::do_request $class_url + # Forum index page + link follow ~u {forum-view?[^/]+$} + # Post question + array set question [get_question] + link follow ~u {message-post?[^/]+$} + field find ~n subject + field fill $question(subject) + field find ~n content + field fill $question(content) + form submit - # Post answers + # Assuming here we are redirected to thread page - fragile... + set thread_url [response url] + + # Post answer + array set answer [get_answer] + ::twt::user::login albert_einstein@dotlrn.test + ::twt::do_request $thread_url + link follow ~u {message-post?[^/]+$} + field find ~n content + field fill $answer(content) + form submit + + ::twt::user::login_site_wide_admin } } + +ad_proc ::twt::forums::get_question {} { + + return { + subject "What is the meaning of life?" + content "Let's step back a moment... + +Why do you want to know the meaning of life? + +Often people ask this question when they really want the answer to some other question. Let's try and get those people back on track with some \"pre-meaning of life\" advice: + + * If you're questioning the meaning of life because you've been unhappy and depressed a good bit, click here. + + * On a related note, if you want to know the meaning of life because you feel useless and worthless, click here. + + * If you want to see our answer so that you can prove your intellectual prowess by poking holes in it, click here. + + * If something awful just happened to you or someone you care about and you don't understand why bad things happen to good people, click here. + ... + From http://www.aristotle.net/~diogenes/meaning1.htm + + Comments? +" + } +} + +ad_proc ::twt::forums::get_answer {} { + + return { + content " + I was impressed by the earnestness of your struggle to find a purpose for the life of the individual and of mankind as a whole. In my opinion there can be no reasonable answer if the question is put this way. If we speak of the purpose and goal of an action we mean simply the question: which kind of desire should we fulfill by the action or its consequences or which undesired consequences should be prevented? We can, of course, also speak in a clear way of the goal of an action from the standpoint of a community to which the individual belongs. In such cases the goal of the action has also to do at least indirectly with fulfillment of desires of the individuals which constitute a society. + + If you ask for the purpose or goal of society as a whole or of an individual taken as a whole the question loses its meaning. This is, of course, even more so if you ask the purpose or meaning of nature in general. For in those cases it seems quite arbitrary if not unreasonable to assume somebody whose desires are connected with the happenings. + + Nevertheless we all feel that it is indeed very reasonable and important to ask ourselves how we should try to conduct our lives. The answer is, in my opinion: satisfaction of the desires and needs of all, as far as this can be achieved, and achievement of harmony and beauty in the human relationships. This presupposes a good deal of conscious thought and of self-education. It is undeniable that the enlightened Greeks and the old Oriental sages had achieved a higher level in this all-important field than what is alive in our schools and universities. +" + } +} Index: openacs-4/etc/install/tcl/global-vars.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/Attic/global-vars.tcl,v diff -u -N --- openacs-4/etc/install/tcl/global-vars.tcl 11 Oct 2003 13:43:46 -0000 1.1 +++ /dev/null 1 Jan 1970 00:00:00 -0000 @@ -1,35 +0,0 @@ -# Global variables used by the test procs to reduce the number -# of parameters we need to pass around to the procs. -# -# @author Peter Marklund - -# TODO: put variables in twt namespace - -global __server_url -set __server_url $server_url - -global __admin_last_name -set __admin_last_name $admin_last_name - -global __admin_email -set __admin_email $admin_email - -global __admin_password -set __admin_password $admin_password - -global __url_history -set __url_history [list] - -global __demo_users_password -if { [info exists demo_users_password] } { - set __demo_users_password $demo_users_password -} else { - set __demo_users_password "guest" -} - -global __dotlrn_users_data_file -if { [info exists dotlrn_users_data_file] } { - set __dotlrn_users_data_file $dotlrn_users_data_file -} else { - set __dotlrn_users_data_file users-data.csv -} Index: openacs-4/etc/install/tcl/news-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/news-procs.tcl,v diff -u -N -r1.3 -r1.4 --- openacs-4/etc/install/tcl/news-procs.tcl 11 Oct 2003 22:10:11 -0000 1.3 +++ openacs-4/etc/install/tcl/news-procs.tcl 12 Oct 2003 01:10:13 -0000 1.4 @@ -11,20 +11,20 @@ set news_item_list [get_items] set class_counter 0 - foreach admin_url [::twt::class::get_admin_urls $server_url "[::twt::dotlrn::current_term_pretty_name]"] { + foreach admin_url [::twt::class::get_admin_urls] { # We want the professor of the class to post the news item # TODO #set email [::twt::class::get_professor $admin_url] #user::login $email [::twt::user::get_password $email] # Admin page of the class - do_request $admin_url + ::twt::do_request $admin_url # News item add link follow ~u {news/+item-create} - set news_item [lindex [::twt::util::get_random_items_from_list $news_item_list 1] 0] + set news_item [lindex [::twt::get_random_items_from_list $news_item_list 1] 0] form find ~a preview set publish_title [lindex $news_item 0] Index: openacs-4/etc/install/tcl/test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/test-procs.tcl,v diff -u -N -r1.2 -r1.3 --- openacs-4/etc/install/tcl/test-procs.tcl 11 Oct 2003 17:20:21 -0000 1.2 +++ openacs-4/etc/install/tcl/test-procs.tcl 12 Oct 2003 01:10:13 -0000 1.3 @@ -9,8 +9,8 @@ set script_dir [file dirname [info script]] -source $script_dir/global-vars.tcl -source $script_dir/util-procs.tcl +source $script_dir/config-procs.tcl +source $script_dir/twt-procs.tcl source $script_dir/user-procs.tcl source $script_dir/admin-procs.tcl source $script_dir/dotlrn-procs.tcl Index: openacs-4/etc/install/tcl/twt-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/twt-procs.tcl,v diff -u -N --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/etc/install/tcl/twt-procs.tcl 12 Oct 2003 01:10:13 -0000 1.1 @@ -0,0 +1,170 @@ +# Procs to support testing OpenACS with Tclwebtest. +# +# Basic utility procs. +# +# @author Peter Marklund + +namespace eval ::twt {} + +ad_proc ::twt::log { message } { + set script_name [file tail [info script]] + puts "" + puts "##############################" + puts "#" + puts "# ${script_name}: $message" + puts "#" + puts "##############################" + puts "" +} + +ad_proc ::twt::do_request { page_url } { + Takes a a url and invokes tclwebtest::do_request. The URL + can either be relative to server root or absolute + (in which case it must start with with http://). +} { + if { [regexp {^http://} $page_url] } { + # We were given an absolute url + set absolute_url $page_url + } else { + # Relative url - prepend system url + set absolute_url "[::twt::config::server_url]/$page_url" + } + + ::tclwebtest::do_request $absolute_url +} + +ad_proc ::twt::get_url_list { page_url link_url_pattern } { + + ::twt::do_request $page_url + + set urls_list [list] + + # Loop over and add all links + set errno "0" + while { $errno == "0" } { + set errno [catch { + array set link_array [link find -next ~u "$link_url_pattern"]} error] + + if { [string equal $errno "0"] } { + set url $link_array(url) + + lappend urls_list $url + } + } + + + return $urls_list +} + +ad_proc ::twt::get_random_items_from_list { list number } { + Given a list and the lenght of the list to return, + return a list with a random subset of items from the input list. +} { + + # Build a list of indices + set index_list [list] + for { set i 0 } { $i < [llength $list] } { incr i } { + lappend index_list $i + } + + # If the list was empty - return + if { [llength $index_list] == 0 } { + return {} + } + + # Cannot return more items than are in the list + if { $number > [llength $list] } { + error "get_random_items_from_list: cannot return $number items from list $list" + } + + # Pick number random indices from the list. Remove each index that we have + # already picked. + set random_indices [list] + for { set index_count 0 } { $index_count < $number } { incr index_count } { + set random_index [randomRange [llength $index_list]] + + lappend random_indices [lindex $index_list $random_index] + + # Remove the index that we picked + set index_list [lreplace $index_list $random_index $random_index] + } + + # Build and return the items at the random indices + set return_list [list] + foreach index $random_indices { + lappend return_list [lindex $list $index] + } + if { [llength $return_list] == 1 } { + return [lindex $return_list 0] + } else { + return $return_list + } +} + +ad_proc ::twt::randomRange {range} { + Given an integer N, return an integer between 0 and N. +} { + + return [expr int([expr rand()] * $range)] +} + +ad_proc ::twt::write_response_to_file { filename } { + Write the HTML body of the last HTTP response to the + file with given path. If the directory of the file doesn't + exist then create it. +} { + + # Create the directory of the output file if it doesn't exist + if { ![file isdirectory [file dirname $filename]] } { + exec mkdir -p [file dirname $filename] + } + set file_id [open "$filename" w+] + puts $file_id "[response body]" +} + +ad_proc ::twt::crawl_links {} { + TODO: This proc currently doesn't crawl nearly as many links as we would like +} { + + global __url_history + + set start_url [lindex $__url_history end] + + # Return if given start URL is external + global __server_url + set absolute_url [tclwebtest::absolute_link $start_url] + if { [string first $__server_url $absolute_url] == -1 } { + #puts "not following link to external url $absolute_url" + return + } + + # Also return if this is the logout link + if { [regexp {/register/logout} $start_url match] } { + #puts "not following logout link" + return + } + + ::twt::do_request $start_url + + set errno 0 + while { $errno == "0" } { + set errno [catch { + array set link_array [link find -next]} error] + + if { [string equal $errno "0"] } { + set url $link_array(url) + + # Don't revisit URL:s we have already tested + # Don't follow relative anchors on pages - can't get them to work with TclWebtest + if { [lsearch -exact $__url_history $url] == -1 && [string range $url 0 0] != "#" } { + #puts "$start_url following url $url" + + lappend __url_history $url + + crawl_links + } else { + #puts "$start_url skipping url $url as visited before" + } + } + } +} Index: openacs-4/etc/install/tcl/user-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/user-procs.tcl,v diff -u -N -r1.3 -r1.4 --- openacs-4/etc/install/tcl/user-procs.tcl 11 Oct 2003 22:10:11 -0000 1.3 +++ openacs-4/etc/install/tcl/user-procs.tcl 12 Oct 2003 01:10:13 -0000 1.4 @@ -27,45 +27,46 @@ } { set email_list [get_users $type] - return [::twt::util::get_random_items_from_list $email_list $number] + return [::twt::get_random_items_from_list $email_list $number] } ad_proc ::twt::user::get_password { email } { - global __demo_users_password - return $__demo_users_password + if { [string equal $email [::twt::config::admin_email]] } { + return [::twt::config::admin_password] + } else { + global __demo_users_password + return $__demo_users_password + } } -ad_proc ::twt::user::login { user_email user_password} { +ad_proc ::twt::user::login { email } { ::twt::user::logout global __server_url # Request the start page - do_request "${__server_url}/register" + ::twt::do_request "${__server_url}/register" # Login the user form find ~n login field find ~n email - field fill "$user_email" + field fill "$email" field find ~n password - field fill "$user_password" + field fill [get_password $email] form submit } ad_proc ::twt::user::logout {} { global __server_url - do_request "${__server_url}/register/logout" + ::twt::do_request "${__server_url}/register/logout" } ad_proc ::twt::user::login_site_wide_admin {} { - global __server_url - global __admin_email - global __admin_password - ::twt::user::login $__admin_email $__admin_password + ::twt::user::login [::twt::config::admin_email] } ad_proc ::twt::user::add { @@ -78,7 +79,7 @@ full_access guest } { - do_request "$server_url/dotlrn/admin/users" + ::twt::do_request "$server_url/dotlrn/admin/users" link follow ~u "user-add" form find ~a "/dotlrn/user-add" @@ -89,9 +90,9 @@ field find ~n "last_name" field fill $last_name field find ~n "password" - field fill [::twt::user::get_password $email] + field fill [get_password $email] field find ~n "password_confirm" - field fill [::twt::user::get_password $email] + field fill [get_password $email] form submit form find ~n add_user @@ -182,7 +183,10 @@ # We want the users to have a known password so people can log in with them set_passwords $server_url - + + # Since Einstein will be posting in all classes + # we make him site-wide-admin + ::twt::user::make_site_wide_admin albert_einstein@dotlrn.test } ad_proc ::twt::user::set_passwords { server_url } { @@ -191,7 +195,7 @@ #puts "setting guest password for user $user_email" # User admin page - do_request "${server_url}/dotlrn/admin/users" + ::twt::do_request "${server_url}/dotlrn/admin/users" form find ~a "users-search" field fill $user_email ~n name @@ -209,3 +213,10 @@ form submit } } + +ad_proc ::twt::user::make_site_wide_admin { email } { + ::twt::do_request [::twt::dotlrn::get_user_admin_url $email] + + # Do nothing if the user is already site-wide-admin + catch {link follow ~u {site-wide-admin-toggle.*value=grant}} +} \ No newline at end of file Index: openacs-4/etc/install/tcl/util-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/etc/install/tcl/Attic/util-procs.tcl,v diff -u -N --- openacs-4/etc/install/tcl/util-procs.tcl 11 Oct 2003 22:10:11 -0000 1.3 +++ /dev/null 1 Jan 1970 00:00:00 -0000 @@ -1,164 +0,0 @@ -# Procs to support testing OpenACS with Tclwebtest. -# -# Utility procs. -# -# @author Peter Marklund - -namespace eval ::twt::util {} - -ad_proc ::twt::util::randomRange {range} { - Given an integer N, return an integer between 0 and N. -} { - - return [expr int([expr rand()] * $range)] -} - -ad_proc ::twt::util::get_random_items_from_list { list number } { - Given a list and the lenght of the list to return, - return a list with a random subset of items from the input list. -} { - - # Build a list of indices - set index_list [list] - for { set i 0 } { $i < [llength $list] } { incr i } { - lappend index_list $i - } - - # If the list was empty - return - if { [llength $index_list] == 0 } { - return {} - } - - # Cannot return more items than are in the list - if { $number > [llength $list] } { - error "get_random_items_from_list: cannot return $number items from list $list" - } - - # Pick number random indices from the list. Remove each index that we have - # already picked. - set random_indices [list] - for { set index_count 0 } { $index_count < $number } { incr index_count } { - set random_index [randomRange [llength $index_list]] - - lappend random_indices [lindex $index_list $random_index] - - # Remove the index that we picked - set index_list [lreplace $index_list $random_index $random_index] - } - - # Build and return the items at the random indices - set return_list [list] - foreach index $random_indices { - lappend return_list [lindex $list $index] - } - if { [llength $return_list] == 1 } { - return [lindex $return_list 0] - } else { - return $return_list - } -} - -ad_proc ::twt::util::write_response_to_file { filename } { - Write the HTML body of the last HTTP response to the - file with given path. If the directory of the file doesn't - exist then create it. -} { - - # Create the directory of the output file if it doesn't exist - if { ![file isdirectory [file dirname $filename]] } { - exec mkdir -p [file dirname $filename] - } - set file_id [open "$filename" w+] - puts $file_id "[response body]" -} - -ad_proc ::twt::util::get_url_list { server_url page_url link_url_pattern } { - - do_request "$page_url" - - set urls_list [list] - - # Loop over and add all links - set errno "0" - while { $errno == "0" } { - set errno [catch { - array set link_array [link find -next ~u "$link_url_pattern"]} error] - - if { [string equal $errno "0"] } { - set url $link_array(url) - - if { [regexp {http://} $url match] } { - # Fully qualified URL - lappend urls_list $url - } elseif { [string index $url 0] == "/" } { - # Absolute path - lappend urls_list ${server_url}${url} - } else { - # Relative path - regexp {(http://[^?]+/)} $page_url match dir_url - lappend urls_list ${dir_url}${url} - } - } - } - - - return $urls_list -} - -ad_proc ::twt::util::crawl_links {} { - TODO: This proc currently doesn't crawl nearly as many links as we would like -} { - - global __url_history - - set start_url [lindex $__url_history end] - - # Return if given start URL is external - global __server_url - set absolute_url [tclwebtest::absolute_link $start_url] - if { [string first $__server_url $absolute_url] == -1 } { - #puts "not following link to external url $absolute_url" - return - } - - # Also return if this is the logout link - if { [regexp {/register/logout} $start_url match] } { - #puts "not following logout link" - return - } - - do_request $start_url - - set errno 0 - while { $errno == "0" } { - set errno [catch { - array set link_array [link find -next]} error] - - if { [string equal $errno "0"] } { - set url $link_array(url) - - # Don't revisit URL:s we have already tested - # Don't follow relative anchors on pages - can't get them to work with TclWebtest - if { [lsearch -exact $__url_history $url] == -1 && [string range $url 0 0] != "#" } { - #puts "$start_url following url $url" - - lappend __url_history $url - - crawl_links - } else { - #puts "$start_url skipping url $url as visited before" - } - } - } -} - -ad_proc ::twt::util::log { message } { - set script_name [file tail [info script]] - puts "" - puts "##############################" - puts "#" - puts "# ${script_name}: $message" - puts "#" - puts "##############################" - puts "" -} \ No newline at end of file