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
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-automated-testing/tcl/tclwebtest-procs.tcl	31 Mar 2004 12:11:09 -0000	1.1
@@ -0,0 +1,153 @@
+ad_library {
+    Helper procs for test cases using tclwebtest (HTTP level tests).
+
+    @author Peter Marklund
+    @creation-date 31 March 2004
+    @cvs-id $Id: tclwebtest-procs.tcl,v 1.1 2004/03/31 12:11:09 peterm Exp $
+}
+
+namespace eval twt {}
+namespace eval twt::user {}
+
+#########################
+#
+# twt namespace
+#
+#########################
+
+ad_proc twt::do_request { page_url } {
+    Takes a a url and invokes tclwebtest::do_request. Will retry
+    the request a number of times if it fails because of a socket
+    connect problem.
+} {
+    # Qualify page_url if necessary
+    if { [regexp {^/} $page_url] } {
+        set page_url "[twt::server_url]${page_url}"
+    }
+
+    set retry_count 0
+    set retry_max 10
+    set error_p 0
+    while { [catch {::tclwebtest::do_request $page_url} errmsg] } {
+        set error_p 1
+
+        if { $retry_count < $retry_max } {
+            switch -regexp -- $errmsg {
+                {unreachable} - {refused} {
+                    ::twt::log "Failed to connect to server with error \"$errmsg\" - retrying"
+                    incr retry_count
+                    exec "sleep" "5"
+                    set error_p 0
+                    continue
+                }
+                default {
+                    ::twt::log "Failed to connect to server with error \"$errmsg\" - giving up"
+                    break
+                }
+            }
+        } else {
+            break
+        }
+    }
+
+    if { $error_p } {
+        # Either some non-socket error, or a socket problem occuring with more than
+        # $retry_max times. Propagate the error while retaining the stack trace
+        global errorInfo
+        error $errmsg $errorInfo
+    }
+
+    #::twt::acs_lang::check_no_keys
+}
+
+ad_proc twt::log { message } {
+    ns_log Notice "twt::log - $message"
+}
+
+ad_proc twt::server_url {} {
+    Get the URL of the server (like ad_url) using the IP number of the server.
+    Is more bulletproof than using the domain name.
+
+    @author Peter Marklund
+} {
+    set ip_address [ns_config ns/server/[ns_info server]/module/nssock Address]
+
+    regexp {(:[0-9]*)?$} [util_current_location] match port
+
+    if { [exists_and_not_null port] } {
+        return "http://${ip_address}${port}"
+    } else {
+        return "http://$ip_address"
+    }
+}
+
+#########################
+#
+# twt::user namespace
+#
+#########################
+
+ad_proc twt::user::create { 
+    {-user_id {}}
+ } {
+    Create a test user with random email and password for testing
+    
+    @return The user_info array list returned by auth::create_user. Contains
+            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 { ![string equal $user_info(creation_status) 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
+
+    return [array get user_info]
+}
+
+ad_proc twt::user::delete {
+    {-user_id:required}
+} {
+    Remove a test user.
+} {
+    acs_user::delete \
+        -user_id $user_id \
+        -permanent
+}
+
+ad_proc twt::user::login { email password } {
+
+    ::twt::user::logout
+
+    # Request the start page
+    ::twt::do_request "[twt::server_url]/register"
+
+    # Login the user
+    tclwebtest::form find ~n login
+    tclwebtest::field find ~n email
+    tclwebtest::field fill "$email"
+    tclwebtest::field find ~n password
+    tclwebtest::field fill $password
+    tclwebtest::form submit
+}
+
+ad_proc twt::user::logout {} {
+    twt::do_request "[twt::server_url]/register/logout"
+}
Index: openacs-4/packages/acs-automated-testing/tcl/test/acs-automated-testing-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-automated-testing/tcl/test/acs-automated-testing-procs.tcl,v
diff -u
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-automated-testing/tcl/test/acs-automated-testing-procs.tcl	31 Mar 2004 12:11:10 -0000	1.1
@@ -0,0 +1,171 @@
+##############################################################################
+#
+#   Copyright 2001, OpenMSG Ltd, Peter Harper.
+#
+#   This file is part of acs-automated-testing.
+#
+##############################################################################
+
+aa_register_init_class "my_init" {
+  An example chunk of initialisation code.
+} {
+  # Constructor
+  aa_export_vars {my_var1 my_var2}
+  
+  set my_var1 "Variable 1"
+  set my_var2 "Variable 2"
+  aa_equals "Do a dummy test on my_var1" $my_var1 "Variable 1"
+  aa_log "Do a test log message"
+} {
+  # Descructor
+  # aa_log, aa_equals, aa_true and aa_false all ignored here.
+  set _my_var1 $my_var1
+  set _my_var2 $my_var2
+  aa_log "Do a log message that should be ignored"
+}
+
+
+aa_register_init_class "my_init2" {
+  An second example chunk of initialisation code.
+} {
+  # Constructor
+  aa_log "The second constructor"
+} {
+  # Descructor
+  aa_log "The second destructor"
+}
+
+
+aa_register_component "my_component" {
+  An example chunk of component code.
+} {
+  aa_export_vars {an_example_value}
+  set an_example_value 1000
+  aa_log "Log message from the example component my_component"
+}
+
+aa_register_case -cats {
+  tcl
+} -init_classes {
+  my_init
+} "aa_example-000" {
+  Tests successful audit writing.
+} {
+  aa_call_component "my_component"
+} {
+  set test_value 1056
+
+  aa_stub aa_example_write_audit_entry {
+    switch $sequence_id {
+      1 {
+        aa_equals "aa_example_write_audit_entry" $name "name1"
+        aa_equals "aa_example_write_audit_entry" $value "value1"
+        return 1
+      }
+      2 {
+        aa_equals "aa_example_write_audit_entry" $name "name2"
+        aa_equals "aa_example_write_audit_entry" $value "value2"
+        return 1
+      }
+    }
+  }
+
+  set entries {{"name1" "value1"} {"name2" "value2"}}
+  set entries_ex $entries
+
+  set result [aa_example_write_audit_entries $entries]
+
+  aa_log "This is a test log message"
+  aa_true "return value true" $result
+  aa_equals "entries parameter not currupted" $entries $entries_ex
+} {
+  aa_equals "Check that test_value is visible here" $test_value "1056"
+  aa_equals "Check that my_component set value is visible here" $an_example_value "1000"
+}
+
+aa_register_case -cats {
+  tcl
+} -init_classes {
+  my_init my_init2
+} "aa-example-001" {
+  Tests un-successful audit writing.
+  First call succeeds, second fails
+} {
+  aa_stub aa_example_write_audit_entry {
+    switch $sequence_id {
+      1 {
+        aa_equals "aa_example_write_audit_entry, name" $name "name1"
+        aa_equals "aa_example_write_audit_entry, value" $value "value1"
+        return 1
+      }
+      2 {
+        aa_equals "aa_example_write_audit_entry, name" $name "name2"
+        aa_equals "aa_example_write_audit_entry, value" $value "value2"
+        return 0
+      }
+    }
+  }
+
+  set entries {{"name1" "value1"} {"name2" "value2"}}
+  set entries_ex $entries
+
+  set result [aa_example_write_audit_entries $entries]
+
+  aa_false "return value false" $result
+  aa_equals "entries parameter not currupted" $entries $entries_ex
+}
+
+aa_register_case -cats {
+  tcl
+} "aa_example-002" {
+  Tests un-successful audit writing.
+  First call fails.
+} {
+  aa_stub aa_example_write_audit_entry {
+    switch $sequence_id {
+      1 {
+        aa_equals "aa_example_write_audit_entry, name" $name "name1"
+        aa_equals "aa_example_write_audit_entry, value" $value "value1"
+        return 0
+      }
+    }
+  }
+
+  set entries {{"name1" "value1"} {"name2" "value2"}}
+  set entries_ex $entries
+
+  set result [aa_example_write_audit_entries $entries]
+
+  aa_false "return value false" $result
+  aa_equals "entries parameter not corrupted" $entries $entries_ex
+}
+
+aa_register_case -cats {
+    security_risk
+} "aa_example-exclusion-security-risk" {
+    If security-risk is not checked, this test shouldn't run
+} {
+    aa_log "Unless security-risk is was checked, you shouldn't see this test."
+}
+
+aa_register_case -cats {web smoke} -libraries tclwebtest tclwebtest_example {
+    A simple test case demonstrating the use of tclwebtest (HTTP level testing).
+
+    @author Peter Marklund
+} {
+    set user_id [db_nextval acs_object_id_seq]
+
+    aa_run_with_teardown \
+        -test_code {
+            # Create test user
+            array set user_info [twt::user::create -user_id $user_id]
+
+            twt::user::login $user_info(email) $user_info(password)
+
+            twt::do_request "/acs-lang"
+
+        } -teardown_code {
+            # TODO: delete test user
+            twt::user::delete -user_id $user_id
+        }
+}
Fisheye: Tag 1.3 refers to a dead (removed) revision in file `openacs-4/packages/acs-automated-testing/tcl/test/example-test-init.tcl'.
Fisheye: No comparison available.  Pass `N' to diff?