Index: openacs-4/packages/acs-tcl/tcl/test/site-nodes-test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/site-nodes-test-procs.tcl,v diff -u -N -r1.10 -r1.11 --- openacs-4/packages/acs-tcl/tcl/test/site-nodes-test-procs.tcl 3 Nov 2018 11:08:16 -0000 1.10 +++ openacs-4/packages/acs-tcl/tcl/test/site-nodes-test-procs.tcl 3 Nov 2018 11:08:47 -0000 1.11 @@ -22,70 +22,70 @@ } { aa_run_with_teardown -rollback -test_code { - aa_log "# 1) mount /doc1 /doc2 /doc1/doc3" - set doc1_name [ad_generate_random_string] - set doc2_name [ad_generate_random_string] - set doc3_name [ad_generate_random_string] - set node1_pkg_id [site_node::instantiate_and_mount \ - -node_name $doc1_name \ - -package_key acs-core-docs] - set node1_node_id [site_node::get_node_id -url "/$doc1_name"] - set node2_pkg_id [site_node::instantiate_and_mount \ - -node_name $doc2_name \ - -package_key acs-core-docs] - set node2_node_id [site_node::get_node_id -url "/$doc2_name"] - set node3_pkg_id [site_node::instantiate_and_mount \ - -parent_node_id $node1_node_id \ - -node_name $doc3_name \ - -package_key acs-core-docs] - set node3_node_id [site_node::get_node_id -url "/$doc1_name/$doc3_name"] + aa_log "# 1) mount /doc1 /doc2 /doc1/doc3" + set doc1_name [ad_generate_random_string] + set doc2_name [ad_generate_random_string] + set doc3_name [ad_generate_random_string] + set node1_pkg_id [site_node::instantiate_and_mount \ + -node_name $doc1_name \ + -package_key acs-core-docs] + set node1_node_id [site_node::get_node_id -url "/$doc1_name"] + set node2_pkg_id [site_node::instantiate_and_mount \ + -node_name $doc2_name \ + -package_key acs-core-docs] + set node2_node_id [site_node::get_node_id -url "/$doc2_name"] + set node3_pkg_id [site_node::instantiate_and_mount \ + -parent_node_id $node1_node_id \ + -node_name $doc3_name \ + -package_key acs-core-docs] + set node3_node_id [site_node::get_node_id -url "/$doc1_name/$doc3_name"] set root_node_id [site_node::get_node_id -url /] - aa_equals "Verify url /doc1 for node1" [site_node::get_url -node_id $node1_node_id] "/$doc1_name/" - aa_equals "Verify url /doc1/doc3 for node3" [site_node::get_url -node_id $node3_node_id] "/$doc1_name/$doc3_name/" - aa_equals "Verify url /doc2 for node2" [site_node::get_url -node_id $node2_node_id] "/$doc2_name/" + aa_equals "Verify url /doc1 for node1" [site_node::get_url -node_id $node1_node_id] "/$doc1_name/" + aa_equals "Verify url /doc1/doc3 for node3" [site_node::get_url -node_id $node3_node_id] "/$doc1_name/$doc3_name/" + aa_equals "Verify url /doc2 for node2" [site_node::get_url -node_id $node2_node_id] "/$doc2_name/" - aa_log "# 2) rename /doc1 => doc4: Test /doc4 /doc4/doc3 /doc2" - set doc4_name [ad_generate_random_string] - site_node::rename -node_id $node1_node_id -name $doc4_name - aa_equals "Check new url /doc4" [site_node::get_node_id -url "/$doc4_name"] $node1_node_id - aa_equals "Check new url /doc4/doc3" [site_node::get_node_id -url "/$doc4_name/$doc3_name"] $node3_node_id - aa_equals "Check old url /doc2" [site_node::get_node_id -url "/$doc2_name"] $node2_node_id - aa_equals "Make sure old url /doc1 now matches /" [site_node::get_node_id -url "/$doc1_name/"] $root_node_id - aa_equals "Make sure old url /doc1/doc3 now matches /" [site_node::get_node_id -url "/$doc1_name/$doc3_name/"] $root_node_id - aa_equals "Verify url /doc4 for node1" [site_node::get_url -node_id $node1_node_id] "/$doc4_name/" - aa_equals "Verify url /doc4/doc3 for node3" [site_node::get_url -node_id $node3_node_id] "/$doc4_name/$doc3_name/" - aa_equals "Verify url /doc2 for node2" [site_node::get_url -node_id $node2_node_id] "/$doc2_name/" + aa_log "# 2) rename /doc1 => doc4: Test /doc4 /doc4/doc3 /doc2" + set doc4_name [ad_generate_random_string] + site_node::rename -node_id $node1_node_id -name $doc4_name + aa_equals "Check new url /doc4" [site_node::get_node_id -url "/$doc4_name"] $node1_node_id + aa_equals "Check new url /doc4/doc3" [site_node::get_node_id -url "/$doc4_name/$doc3_name"] $node3_node_id + aa_equals "Check old url /doc2" [site_node::get_node_id -url "/$doc2_name"] $node2_node_id + aa_equals "Make sure old url /doc1 now matches /" [site_node::get_node_id -url "/$doc1_name/"] $root_node_id + aa_equals "Make sure old url /doc1/doc3 now matches /" [site_node::get_node_id -url "/$doc1_name/$doc3_name/"] $root_node_id + aa_equals "Verify url /doc4 for node1" [site_node::get_url -node_id $node1_node_id] "/$doc4_name/" + aa_equals "Verify url /doc4/doc3 for node3" [site_node::get_url -node_id $node3_node_id] "/$doc4_name/$doc3_name/" + aa_equals "Verify url /doc2 for node2" [site_node::get_url -node_id $node2_node_id] "/$doc2_name/" - aa_log "# 3) init_cache: Test /doc5 /doc5/doc3 /doc2" - set doc5_name [ad_generate_random_string] - db_dml rename_node1 { - update site_nodes - set name = :doc5_name - where node_id = :node1_node_id - } + aa_log "# 3) init_cache: Test /doc5 /doc5/doc3 /doc2" + set doc5_name [ad_generate_random_string] + db_dml rename_node1 { + update site_nodes + set name = :doc5_name + where node_id = :node1_node_id + } ns_cache_transaction_rollback - site_node::init_cache + site_node::init_cache ns_cache_transaction_begin - aa_equals "Check url /doc5" [site_node::get_node_id -url "/$doc5_name"] $node1_node_id - aa_equals "Check url /doc5/doc3" [site_node::get_node_id -url "/$doc5_name/$doc3_name"] $node3_node_id - aa_equals "Check url /doc2" [site_node::get_node_id -url "/$doc2_name"] $node2_node_id - aa_equals "Make sure old url /doc1 now matches" [site_node::get_node_id -url "/$doc1_name/"] $root_node_id - aa_equals "Make sure old url /doc1/doc3 now matches" [site_node::get_node_id -url "/$doc1_name/$doc3_name/"] $root_node_id - aa_equals "Make sure old url /doc4 now matches" [site_node::get_node_id -url "/$doc4_name/"] $root_node_id - aa_equals "Make sure old url /doc4/doc3 now matches" [site_node::get_node_id -url "/$doc4_name/$doc3_name/"] $root_node_id - aa_equals "Verify url /doc5 for node1" [site_node::get_url -node_id $node1_node_id] "/$doc5_name/" - aa_equals "Verify url /doc5/doc3 for node3" [site_node::get_url -node_id $node3_node_id] "/$doc5_name/$doc3_name/" - aa_equals "Verify url /doc2 for node2" [site_node::get_url -node_id $node2_node_id] "/$doc2_name/" + aa_equals "Check url /doc5" [site_node::get_node_id -url "/$doc5_name"] $node1_node_id + aa_equals "Check url /doc5/doc3" [site_node::get_node_id -url "/$doc5_name/$doc3_name"] $node3_node_id + aa_equals "Check url /doc2" [site_node::get_node_id -url "/$doc2_name"] $node2_node_id + aa_equals "Make sure old url /doc1 now matches" [site_node::get_node_id -url "/$doc1_name/"] $root_node_id + aa_equals "Make sure old url /doc1/doc3 now matches" [site_node::get_node_id -url "/$doc1_name/$doc3_name/"] $root_node_id + aa_equals "Make sure old url /doc4 now matches" [site_node::get_node_id -url "/$doc4_name/"] $root_node_id + aa_equals "Make sure old url /doc4/doc3 now matches" [site_node::get_node_id -url "/$doc4_name/$doc3_name/"] $root_node_id + aa_equals "Verify url /doc5 for node1" [site_node::get_url -node_id $node1_node_id] "/$doc5_name/" + aa_equals "Verify url /doc5/doc3 for node3" [site_node::get_url -node_id $node3_node_id] "/$doc5_name/$doc3_name/" + aa_equals "Verify url /doc2 for node2" [site_node::get_url -node_id $node2_node_id] "/$doc2_name/" - aa_log "# 4) delete doc3: Test /doc5 /doc2, nonexisting /doc5/doc3" - site_node::unmount -node_id $node3_node_id - site_node::delete -node_id $node3_node_id - aa_equals "Check url /doc5" [site_node::get_node_id -url "/$doc5_name"] $node1_node_id - aa_equals "Check url /doc2" [site_node::get_node_id -url "/$doc2_name"] $node2_node_id - aa_equals "Make sure old url /doc5/doc3 now matches /doc5" [site_node::get_node_id -url "/$doc5_name/$doc3_name/"] $node1_node_id - aa_equals "Verify url /doc5 for node1" [site_node::get_url -node_id $node1_node_id] "/$doc5_name/" - aa_equals "Verify url /doc2 for node2" [site_node::get_url -node_id $node2_node_id] "/$doc2_name/" + aa_log "# 4) delete doc3: Test /doc5 /doc2, nonexisting /doc5/doc3" + site_node::unmount -node_id $node3_node_id + site_node::delete -node_id $node3_node_id + aa_equals "Check url /doc5" [site_node::get_node_id -url "/$doc5_name"] $node1_node_id + aa_equals "Check url /doc2" [site_node::get_node_id -url "/$doc2_name"] $node2_node_id + aa_equals "Make sure old url /doc5/doc3 now matches /doc5" [site_node::get_node_id -url "/$doc5_name/$doc3_name/"] $node1_node_id + aa_equals "Verify url /doc5 for node1" [site_node::get_url -node_id $node1_node_id] "/$doc5_name/" + aa_equals "Verify url /doc2 for node2" [site_node::get_url -node_id $node2_node_id] "/$doc2_name/" } } Index: openacs-4/packages/acs-tcl/tcl/test/acs-tcl-test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/acs-tcl-test-procs.tcl,v diff -u -N -r1.68 -r1.69 --- openacs-4/packages/acs-tcl/tcl/test/acs-tcl-test-procs.tcl 2 Nov 2018 10:12:32 -0000 1.68 +++ openacs-4/packages/acs-tcl/tcl/test/acs-tcl-test-procs.tcl 3 Nov 2018 11:15:16 -0000 1.69 @@ -219,7 +219,7 @@ apm_remove_callback_proc -package_key $package_key -type $type if { $error_p } { - error "$error - $::errorInfo" + error "$error - $::errorInfo" } } Index: openacs-4/packages/acs-tcl/tcl/test/community-core-test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/community-core-test-procs.tcl,v diff -u -N -r1.8 -r1.9 --- openacs-4/packages/acs-tcl/tcl/test/community-core-test-procs.tcl 25 Jul 2018 13:42:48 -0000 1.8 +++ openacs-4/packages/acs-tcl/tcl/test/community-core-test-procs.tcl 3 Nov 2018 11:15:16 -0000 1.9 @@ -1,6 +1,6 @@ ad_library { Test cases for community core procs. - + @author byron Haroldo Linares Roman (bhlr@galileo.edu) @creation-date 2006-07-28 @cvs-id $Id$ @@ -14,21 +14,21 @@ } \ community_cc_procs \ { - test community core procs returned values + test community core procs returned values } { - aa_run_with_teardown -rollback -test_code { + aa_run_with_teardown -rollback -test_code { set user_id [db_nextval acs_object_id_seq] set username [ad_generate_random_string] set password [ad_generate_random_string] - - array set user_info [acs::test::user::create -user_id $user_id] - set user_id_p [party::get_by_email -email $user_info(email)] - aa_true "User ID CORRECTO" \ - [string match $user_id_p $user_info(user_id)] - set email_p [party::email -party_id $user_info(user_id)] - aa_log "returns: $email_p , creation: $user_info(email)" - aa_true "Email correcto" \ - [string match $email_p [string tolower $user_info(email)]] + + array set user_info [acs::test::user::create -user_id $user_id] + set user_id_p [party::get_by_email -email $user_info(email)] + aa_true "User ID CORRECTO" \ + [string match $user_id_p $user_info(user_id)] + set email_p [party::email -party_id $user_info(user_id)] + aa_log "returns: $email_p , creation: $user_info(email)" + aa_true "Email correcto" \ + [string match $email_p [string tolower $user_info(email)]] } } @@ -47,63 +47,63 @@ } \ person_procs_test \ { - Test whether the values returned by the person procs are correct. + Test whether the values returned by the person procs are correct. } { - - set user_id [db_nextval acs_object_id_seq] - set username "[ad_generate_random_string]" - set email "${username}@test.test" - set password [ad_generate_random_string] - set first_names [ad_generate_random_string] - set last_name [ad_generate_random_string] - array 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]] - - 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\" user_id=$user_info(user_id)" - - aa_run_with_teardown -rollback \ - -test_code { - - aa_true "party is a person" [person::person_p -party_id $user_id] + set user_id [db_nextval acs_object_id_seq] + set username "[ad_generate_random_string]" + set email "${username}@test.test" + set password [ad_generate_random_string] + set first_names [ad_generate_random_string] + set last_name [ad_generate_random_string] - array set user_inf [person::get -person_id $user_info(user_id)] - - aa_true "first_names correct" [string match $user_inf(first_names) $first_names] - aa_true "last_name correct" [string match $user_inf(last_name) $last_name] - aa_true "person_id correct" [string match $user_inf(person_id) $user_id] - aa_true "correct name" [string match [person::name -person_id $user_info(user_id)] "$first_names $last_name"] + array 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]] - set prs_id [person::new -first_names $first_names -last_name $last_name -email "${email}s"] - set email_p [party::email -party_id $prs_id] - aa_true "New person pass" [string match $email_p [string tolower "${email}s"]] + 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\" user_id=$user_info(user_id)" + + aa_run_with_teardown -rollback \ + -test_code { + + aa_true "party is a person" [person::person_p -party_id $user_id] + + array set user_inf [person::get -person_id $user_info(user_id)] + + aa_true "first_names correct" [string match $user_inf(first_names) $first_names] + aa_true "last_name correct" [string match $user_inf(last_name) $last_name] + aa_true "person_id correct" [string match $user_inf(person_id) $user_id] + aa_true "correct name" [string match [person::name -person_id $user_info(user_id)] "$first_names $last_name"] + + set prs_id [person::new -first_names $first_names -last_name $last_name -email "${email}s"] + set email_p [party::email -party_id $prs_id] + aa_true "New person pass" [string match $email_p [string tolower "${email}s"]] + aa_log "New Person has user_id=$prs_id email_p=$email_p" aa_log "Is this ID in persons ? [db_list _ {select * from persons where person_id=:prs_id}]" aa_log "Is this ID in users ? [db_list _ {select * from cc_users where user_id=:prs_id}]" - person::update -person_id $prs_id -first_names "hh$first_names" -last_name "hh$last_name" - aa_true "name changed" [string match [person::name -person_id $prs_id] "hh$first_names hh$last_name"] - - set bio "bio :: [ad_generate_random_string] :: bio" - person::update_bio -person_id $prs_id -bio $bio - - aa_true "bio(graphy) ok" [string match $bio [person::get_bio -person_id $prs_id -exists_var bio_p]] - - person::delete -person_id $prs_id + person::update -person_id $prs_id -first_names "hh$first_names" -last_name "hh$last_name" + aa_true "name changed" [string match [person::name -person_id $prs_id] "hh$first_names hh$last_name"] + + set bio "bio :: [ad_generate_random_string] :: bio" + person::update_bio -person_id $prs_id -bio $bio + + aa_true "bio(graphy) ok" [string match $bio [person::get_bio -person_id $prs_id -exists_var bio_p]] + + person::delete -person_id $prs_id aa_true "person deleted" ![person::person_p -party_id $prs_id] - } + } } aa_register_case \ @@ -114,43 +114,43 @@ } \ party_procs_test \ { - test if the values returned by the party procs are correct + test if the values returned by the party procs are correct } { - + set user_id [db_nextval acs_object_id_seq] set username "[ad_generate_random_string]" set email "${username}@test.test" set password [ad_generate_random_string] set first_names [ad_generate_random_string] set last_name [ad_generate_random_string] - set url "url[ad_generate_random_string]" - - array set user_info [auth::create_user \ + set url "url[ad_generate_random_string]" + + array set user_info [auth::create_user \ -user_id $user_id \ -username $username \ -email $email \ -first_names $first_names \ - -last_name $last_name \ + -last_name $last_name \ -password $password \ - -secret_question [ad_generate_random_string] \ - -secret_answer [ad_generate_random_string]] - + -secret_question [ad_generate_random_string] \ + -secret_answer [ad_generate_random_string]] + if { $user_info(creation_status) ne "ok" } { - # Could not create user + # 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\"" - aa_run_with_teardown -rollback \ + aa_run_with_teardown -rollback \ -test_code { - aa_true "correct party_id" [string match [party::get_by_email -email $email] $user_info(user_id)] - party::update -party_id $user_info(user_id) -email "${email}2" -url $url - aa_true "correct party with new mail" [string match [party::get_by_email -email "${email}2"] $user_info(user_id)] - } + aa_true "correct party_id" [string match [party::get_by_email -email $email] $user_info(user_id)] + party::update -party_id $user_info(user_id) -email "${email}2" -url $url + aa_true "correct party with new mail" [string match [party::get_by_email -email "${email}2"] $user_info(user_id)] + } } Index: openacs-4/packages/acs-tcl/tcl/test/datamodel-test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/datamodel-test-procs.tcl,v diff -u -N -r1.19 -r1.20 --- openacs-4/packages/acs-tcl/tcl/test/datamodel-test-procs.tcl 25 Jul 2018 13:42:48 -0000 1.19 +++ openacs-4/packages/acs-tcl/tcl/test/datamodel-test-procs.tcl 3 Nov 2018 11:15:16 -0000 1.20 @@ -12,7 +12,7 @@ -error_level warning \ -procs {} \ datamodel__named_constraints { - + Check that all the constraints meet the constraint naming standards. @@ -22,79 +22,79 @@ set db_is_pg_p [string equal [db_name] "PostgreSQL"] if { $db_is_pg_p } { - set get_constraints "select - cla.relname as table_name, - con.conrelid, - con.conname as constraint_name, - CASE - when con.contype='c' then 'ck' - when con.contype='f' then 'fk' - when con.contype='p' then 'pk' - when con.contype='u' then 'un' - else '' - END as constraint_type, - con.conkey, + set get_constraints "select + cla.relname as table_name, + con.conrelid, + con.conname as constraint_name, + CASE + when con.contype='c' then 'ck' + when con.contype='f' then 'fk' + when con.contype='p' then 'pk' + when con.contype='u' then 'un' + else '' + END as constraint_type, + con.conkey, '' as search_condition - from - pg_constraint con, - pg_class cla - where con.conrelid != 0 and cla.oid=con.conrelid - order by table_name,constraint_name" - set get_constraint_col "select attname from pg_attribute where attnum = :columns_list and attrelid = :conrelid" + from + pg_constraint con, + pg_class cla + where con.conrelid != 0 and cla.oid=con.conrelid + order by table_name,constraint_name" + set get_constraint_col "select attname from pg_attribute where attnum = :columns_list and attrelid = :conrelid" } else { - # Oracle - set get_constraints "select - acc.*, ac.search_condition, - decode(ac.constraint_type,'C','CK','R','FK','P','PK','U','UN','') as constraint_type - from - (select count(column_name) as columns, table_name, constraint_name from user_cons_columns group by table_name, constraint_name) acc, - user_constraints ac - where ac.constraint_name = acc.constraint_name - order by acc.table_name, acc.constraint_name" - set get_constraint_col "select column_name from user_cons_columns where constraint_name = :constraint_name" + # Oracle + set get_constraints "select + acc.*, ac.search_condition, + decode(ac.constraint_type,'C','CK','R','FK','P','PK','U','UN','') as constraint_type + from + (select count(column_name) as columns, table_name, constraint_name from user_cons_columns group by table_name, constraint_name) acc, + user_constraints ac + where ac.constraint_name = acc.constraint_name + order by acc.table_name, acc.constraint_name" + set get_constraint_col "select column_name from user_cons_columns where constraint_name = :constraint_name" } db_foreach check_constraints $get_constraints { - if { $db_is_pg_p || [string last "$" $table_name] eq -1 } { + if { $db_is_pg_p || [string last "$" $table_name] eq -1 } { - regsub {_[[:alpha:]]+$} $constraint_name "" name_without_type - set standard_name "${name_without_type}_${constraint_type}" + regsub {_[[:alpha:]]+$} $constraint_name "" name_without_type + set standard_name "${name_without_type}_${constraint_type}" set standard_name_alt "${name_without_type}_[ad_decode $constraint_type pk pkey fk fkey un key ck ck missing]" - if { $db_is_pg_p } { - set columns_list [split [string range $conkey 1 end-1] ","] - set columns [llength $columns_list] - } + if { $db_is_pg_p } { + set columns_list [split [string range $conkey 1 end-1] ","] + set columns [llength $columns_list] + } - if { $columns eq 1 } { + if { $columns eq 1 } { - set column_name [db_string get_col $get_constraint_col] - - # NOT NULL constraints (oracle only) - if { [string equal $search_condition "\"$column_name\" IS NOT NULL"] } { - set constraint_type "NN" - } + set column_name [db_string get_col $get_constraint_col] - set standard_name ${table_name}_${column_name}_${constraint_type} + # NOT NULL constraints (oracle only) + if { [string equal $search_condition "\"$column_name\" IS NOT NULL"] } { + set constraint_type "NN" + } - if { [string length $standard_name] > 30 } { - # Only check the abbreviation - set standard_name "${name_without_type}_${constraint_type}" - } - } + set standard_name ${table_name}_${column_name}_${constraint_type} - # Giving a hint for constraint naming - if {[string range $standard_name 0 2] eq "SYS"} { - set hint "unnamed" - } else { - set hint "hint: $standard_name" - } + if { [string length $standard_name] > 30 } { + # Only check the abbreviation + set standard_name "${name_without_type}_${constraint_type}" + } + } - if { $standard_name ne $constraint_name + # Giving a hint for constraint naming + if {[string range $standard_name 0 2] eq "SYS"} { + set hint "unnamed" + } else { + set hint "hint: $standard_name" + } + + if { $standard_name ne $constraint_name && $standard_name_alt ne $constraint_name } { - aa_log_result fail "Table $table_name constraint $constraint_name ($constraint_type) violates naming standard ($hint)" - } - } + aa_log_result fail "Table $table_name constraint $constraint_name ($constraint_type) violates naming standard ($hint)" + } + } } } @@ -104,7 +104,7 @@ -cats {db smoke production_safe} \ -procs {db_table_exists} \ datamodel__acs_object_type_check { - + Check that the object type tables exist and that the id column is present and the name method works. @@ -121,20 +121,20 @@ set id_column [string tolower $id_column] set the_pk {} - while { [string is space $table_name] && $object_type ne $supertype } { - if {![db_0or1row get_supertype "select * from acs_object_types where object_type = :supertype"]} { - break - } - } - if {![db_table_exists $table_name]} { + while { [string is space $table_name] && $object_type ne $supertype } { + if {![db_0or1row get_supertype "select * from acs_object_types where object_type = :supertype"]} { + break + } + } + if {![db_table_exists $table_name]} { aa_log_result fail "Type $object_type: table $table_name does not exit" } else { if {[string is space $id_column]} { aa_log_result fail "Type $object_type: id_column not specified" } else { - # we could just check the column exists but since we want to + # we could just check the column exists but since we want to # check the name method try at least to get a real object_id - if {[catch {db_0or1row check_exists "select min($id_column) as the_pk from $table_name"} errMsg]} { + if {[catch {db_0or1row check_exists "select min($id_column) as the_pk from $table_name"} errMsg]} { aa_log_result fail "Type $object_type: select $id_column from $table_name failed:\n$errMsg" } } @@ -146,15 +146,15 @@ } set name_method [string tolower $name_method] if {[string is integer -strict $the_pk]} { - # intentionally don't use bind variables here which is ok + # intentionally don't use bind variables here which is ok # since we just checked the_pk was an integer - if { [catch {db_0or1row name_method "select ${name_method}($the_pk) as NAME from dual"} errMsg] } { + if { [catch {db_0or1row name_method "select ${name_method}($the_pk) as NAME from dual"} errMsg] } { aa_log_result fail "Type $object_type: name method $name_method failed\n$errMsg" } } } - if {![string is space $type_extension_table] - && ![db_table_exists $type_extension_table]} { + if {![string is space $type_extension_table] + && ![db_table_exists $type_extension_table]} { aa_log_result fail "Type $object_type: type extension table $type_extension_table does not exist" } } @@ -166,7 +166,7 @@ -cats {db smoke production_safe} \ -procs {db_column_type db_columns} \ datamodel__acs_attribute_check { - + Check that the acs_attribute column is present and the datatype is vaguely consistent with the db datatype. Index: openacs-4/packages/acs-tcl/tcl/test/html-conversion-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/html-conversion-procs.tcl,v diff -u -N -r1.19 -r1.20 --- openacs-4/packages/acs-tcl/tcl/test/html-conversion-procs.tcl 23 Oct 2018 18:38:36 -0000 1.19 +++ openacs-4/packages/acs-tcl/tcl/test/html-conversion-procs.tcl 3 Nov 2018 11:15:16 -0000 1.20 @@ -83,13 +83,13 @@

following text }} { - set result [ad_html_to_text -- $html] + set result [ad_html_to_text -- $html] - # make sure the desired text is in there and _before_ the - # footnotes + # make sure the desired text is in there and _before_ the + # footnotes - aa_true "contains link" [regexp {linktext.*\[1\]} $result] - aa_true "contains following text" [regexp {following text.*\[1\]} $result] + aa_true "contains link" [regexp {linktext.*\[1\]} $result] + aa_true "contains following text" [regexp {following text.*\[1\]} $result] } } @@ -315,7 +315,7 @@ set html "

some text to probe if it remove all between \"<\" and \">\"
" set result [util_remove_html_tags $html] aa_equals "Without all between \"<\" and \">\" html=\"$result\""\ - "some text to probe if it remove all between \"\"" $result + "some text to probe if it remove all between \"\"" $result } aa_register_case \ @@ -357,27 +357,27 @@ aa_equals "Standard HTML Comments cleaned $result" $result "" set html { } + {behavior:url(MESSAGE KEY MISSING: 'default'VML);} w\:* {behavior:url(MESSAGE KEY MISSING: 'default'VML);} + .shape {behavior:url(MESSAGE KEY MISSING: 'default'VML);} } set result [ad_html_text_convert -from text/html -to text/plain $html] @@ -481,22 +481,22 @@ -bugs 1450 \ -procs {ad_enhanced_text_to_html} \ acs_tcl__process_enhanced_correctly { - - Process sample text correctly - @author Nima Mazloumi + + Process sample text correctly + @author Nima Mazloumi } { - - set string_with_img {} - aa_log "Original string is $string_with_img" - set html_version [ad_enhanced_text_to_html $string_with_img] - aa_equals "new: $html_version should be the same" $html_version $string_with_img + + set string_with_img {} + aa_log "Original string is $string_with_img" + set html_version [ad_enhanced_text_to_html $string_with_img] + aa_equals "new: $html_version should be the same" $html_version $string_with_img } aa_register_case \ -cats {api smoke} \ -procs {ad_html_to_text} \ text_to_html { - + Test code the supposedly causes ad_html_to_text to break } { Index: openacs-4/packages/acs-tcl/tcl/test/html-email-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/html-email-procs.tcl,v diff -u -N -r1.5 -r1.6 --- openacs-4/packages/acs-tcl/tcl/test/html-email-procs.tcl 25 Jul 2018 13:42:48 -0000 1.5 +++ openacs-4/packages/acs-tcl/tcl/test/html-email-procs.tcl 3 Nov 2018 11:15:16 -0000 1.6 @@ -9,12 +9,12 @@ Basic test of build mime message } { aa_false "Build mime message, no error" \ - [catch {build_mime_message \ - "Test Message" \ - "

Test Message

"} errmsg] + [catch {build_mime_message \ + "Test Message" \ + "

Test Message

"} errmsg] aa_log err=$errmsg aa_false "Package require mime package found" \ - [catch {package require mime} errmsg] + [catch {package require mime} errmsg] } Index: openacs-4/packages/acs-tcl/tcl/test/location-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/location-procs.tcl,v diff -u -N -r1.1 -r1.2 --- openacs-4/packages/acs-tcl/tcl/test/location-procs.tcl 13 Sep 2018 06:20:36 -0000 1.1 +++ openacs-4/packages/acs-tcl/tcl/test/location-procs.tcl 3 Nov 2018 11:15:16 -0000 1.2 @@ -1,47 +1,47 @@ aa_register_case \ -cats {api smoke} \ -procs { - security::get_secure_location - security::get_insecure_location - util_current_location + security::get_secure_location + security::get_insecure_location + util_current_location } \ get_insecure_location { Test if security::get_insecure_location is working as expected. - + @author Gustaf Neumann } { aa_run_with_teardown -rollback -test_code { - aa_section "security::get_insecure_location" + aa_section "security::get_insecure_location" - set current_location [util_current_location] - aa_log "current location '$current_location'" + set current_location [util_current_location] + aa_log "current location '$current_location'" - set cld [ns_parseurl $current_location] - aa_log "current location parts '$cld'" - if {[dict exists $cld port] && [dict get $cld port] ne ""} { - if {[dict get $cld proto] eq "http"} { - aa_log "run tests with port based on HTTP" - set insecure [security::get_insecure_location] - aa_true "insecure location has same proto as current location" {$insecure eq $current_location} - - set secure [security::get_secure_location] - set sld [ns_parseurl $secure] - aa_true "secure location starts is HTTPS" {[dict get $sld proto] eq "https"} - } else { - aa_log "run tests with port based on HTTPS" - set secure [security::get_secure_location] - aa_true "secure location has same proto as current location" {$insecure eq $current_location} + set cld [ns_parseurl $current_location] + aa_log "current location parts '$cld'" + if {[dict exists $cld port] && [dict get $cld port] ne ""} { + if {[dict get $cld proto] eq "http"} { + aa_log "run tests with port based on HTTP" + set insecure [security::get_insecure_location] + aa_true "insecure location has same proto as current location" {$insecure eq $current_location} - set insecure [security::get_insecure_location] - set ild [ns_parseurl $insecure] - aa_true "insecure location starts is HTTP" {[dict get $ild proto] eq "https"} - } - } else { - aa_log "skip tests with port" - } + set secure [security::get_secure_location] + set sld [ns_parseurl $secure] + aa_true "secure location starts is HTTPS" {[dict get $sld proto] eq "https"} + } else { + aa_log "run tests with port based on HTTPS" + set secure [security::get_secure_location] + aa_true "secure location has same proto as current location" {$insecure eq $current_location} + set insecure [security::get_insecure_location] + set ild [ns_parseurl $insecure] + aa_true "insecure location starts is HTTP" {[dict get $ild proto] eq "https"} + } + } else { + aa_log "skip tests with port" + } + } } Index: openacs-4/packages/acs-tcl/tcl/test/object-test-case-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/object-test-case-procs.tcl,v diff -u -N -r1.8 -r1.9 --- openacs-4/packages/acs-tcl/tcl/test/object-test-case-procs.tcl 25 Jul 2018 13:42:48 -0000 1.8 +++ openacs-4/packages/acs-tcl/tcl/test/object-test-case-procs.tcl 3 Nov 2018 11:15:16 -0000 1.9 @@ -1,5 +1,5 @@ ad_library { - + @author byron Haroldo Linares Roman (bhlr@galileo.edu) @creation-date 2006-08-11 @cvs-id $Id$ @@ -13,121 +13,121 @@ acs_object::set_context_id } acs_object_procs_test \ { - test the acs_object::* procs + test the acs_object::* procs } { - set pretty_name [ad_generate_random_string] - set object_type [string tolower $pretty_name] - set name_method "${object_type}.name" - set creation_user [ad_conn user_id] - set creation_ip [ad_conn peeraddr] - set context_id [ad_conn package_id] - set context_id2 [apm_package_id_from_key "acs-tcl"] - set the_id [db_nextval acs_object_id_seq] - aa_run_with_teardown -test_code { + set pretty_name [ad_generate_random_string] + set object_type [string tolower $pretty_name] + set name_method "${object_type}.name" + set creation_user [ad_conn user_id] + set creation_ip [ad_conn peeraddr] + set context_id [ad_conn package_id] + set context_id2 [apm_package_id_from_key "acs-tcl"] + set the_id [db_nextval acs_object_id_seq] + aa_run_with_teardown -test_code { - if {[db_name] eq "PostgreSQL"} { - set type_create_sql "select acs_object_type__create_type ( - :object_type, - :pretty_name, - :pretty_name, - 'acs_object', - null, - null, - null, - 'f', - null, - :name_method);" - - set new_type_sql "select acs_object__new ( - :the_id, - :object_type, - now(), - :creation_user, - :creation_ip, - :context_id - );" - set object_del_sql "select acs_object__delete(:the_id)" - set type_drop_sql "select acs_object_type__drop_type( - :object_type, - 't' - )" - } else { - # oracle - set type_create_sql "begin - acs_object_type.create_type ( - object_type => :object_type, - pretty_name => :pretty_name, - pretty_plural => :pretty_name, - supertype => 'acs_object', - abstract_p => 'f', - name_method => :name_method); + if {[db_name] eq "PostgreSQL"} { + set type_create_sql "select acs_object_type__create_type ( + :object_type, + :pretty_name, + :pretty_name, + 'acs_object', + null, + null, + null, + 'f', + null, + :name_method);" + + set new_type_sql "select acs_object__new ( + :the_id, + :object_type, + now(), + :creation_user, + :creation_ip, + :context_id + );" + set object_del_sql "select acs_object__delete(:the_id)" + set type_drop_sql "select acs_object_type__drop_type( + :object_type, + 't' + )" + } else { + # oracle + set type_create_sql "begin + acs_object_type.create_type ( + object_type => :object_type, + pretty_name => :pretty_name, + pretty_plural => :pretty_name, + supertype => 'acs_object', + abstract_p => 'f', + name_method => :name_method); end;" - - set new_type_sql "begin + + set new_type_sql "begin :1 := acs_object.new ( - object_id => :the_id, - object_type => :object_type, - creation_user => :creation_user, - creation_ip => :creation_ip, - context_id => :context_id); + object_id => :the_id, + object_type => :object_type, + creation_user => :creation_user, + creation_ip => :creation_ip, + context_id => :context_id); end;" - set object_del_sql "begin + set object_del_sql "begin acs_object.del(:the_id); end;" - set type_drop_sql "begin + set type_drop_sql "begin acs_object_type.drop_type(object_type => :object_type); end;" - } + } - aa_log "test object_type $object_type :: $context_id2" + aa_log "test object_type $object_type :: $context_id2" - db_exec_plsql type_create $type_create_sql - - set the2_id [db_exec_plsql new_type $new_type_sql] - - acs_object::get -object_id $the_id -array array - - aa_true "object_id $the_id :: $array(object_id)" \ - [string match $the_id $array(object_id)] - - aa_true "object_type $object_type :: $array(object_type)" \ - [string match $object_type $array(object_type)] - - aa_true "context_id $context_id :: $array(context_id)" \ - [string match $context_id $array(context_id)] - - aa_true \ - "creation_user $creation_user :: [acs_object::get_element -object_id $the_id -element creation_user]" \ - [string match $creation_user [acs_object::get_element \ - -object_id $the_id \ - -element creation_user]] - aa_true \ - "creation_ip $creation_ip :: [acs_object::get_element -object_id $the_id -element creation_ip]" \ - [string match $creation_ip [acs_object::get_element \ - -object_id $the_id \ - -element creation_ip]] + db_exec_plsql type_create $type_create_sql - acs_object::set_context_id -object_id $the_id \ - -context_id $context_id2 - - aa_true \ - "context_id $context_id2 :: [acs_object::get_element -object_id $the_id -element context_id]" \ - [string match $context_id2 [acs_object::get_element \ + set the2_id [db_exec_plsql new_type $new_type_sql] + + acs_object::get -object_id $the_id -array array + + aa_true "object_id $the_id :: $array(object_id)" \ + [string match $the_id $array(object_id)] + + aa_true "object_type $object_type :: $array(object_type)" \ + [string match $object_type $array(object_type)] + + aa_true "context_id $context_id :: $array(context_id)" \ + [string match $context_id $array(context_id)] + + aa_true \ + "creation_user $creation_user :: [acs_object::get_element -object_id $the_id -element creation_user]" \ + [string match $creation_user [acs_object::get_element \ + -object_id $the_id \ + -element creation_user]] + aa_true \ + "creation_ip $creation_ip :: [acs_object::get_element -object_id $the_id -element creation_ip]" \ + [string match $creation_ip [acs_object::get_element \ -object_id $the_id \ + -element creation_ip]] + + acs_object::set_context_id -object_id $the_id \ + -context_id $context_id2 + + aa_true \ + "context_id $context_id2 :: [acs_object::get_element -object_id $the_id -element context_id]" \ + [string match $context_id2 [acs_object::get_element \ + -object_id $the_id \ -element context_id]] - - } -teardown_code { - db_exec_plsql object_del $object_del_sql - db_exec_plsql type_drop $type_drop_sql - } + } -teardown_code { + + db_exec_plsql object_del $object_del_sql + db_exec_plsql type_drop $type_drop_sql + } } Index: openacs-4/packages/acs-tcl/tcl/test/openacs-kernel-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/openacs-kernel-procs.tcl,v diff -u -N -r1.4 -r1.5 --- openacs-4/packages/acs-tcl/tcl/test/openacs-kernel-procs.tcl 25 Jul 2018 13:42:48 -0000 1.4 +++ openacs-4/packages/acs-tcl/tcl/test/openacs-kernel-procs.tcl 3 Nov 2018 11:15:16 -0000 1.5 @@ -10,33 +10,33 @@ Test block execution for rows in a csv file. } { aa_run_with_teardown -test_code { - - # Create cvs file - set file_loc "/tmp/test.csv" - set file_id [open $file_loc w] - puts $file_id "first_name,last_name,instrument" - puts $file_id "Charles,Mingus,Bass" - puts $file_id "Miles,Davis,Trumpet" - puts $file_id "Jhon,Coltrane,Saxo" - puts $file_id "Charlie,Parker,Saxo" - puts $file_id "Thelonius,Monk,Piano" - close $file_id - - set csv_data "\nfirst_name,last_name,instrument\nCharles,Mingus,Bass\nMiles,Davis,Trumpet\nJhon,Coltrane,Saxo\nCharlie,Parker,Saxo\nThelonius,Monk,Piano" - aa_log "CSV file created with artists data:\n $csv_data" + # Create cvs file + set file_loc "/tmp/test.csv" + set file_id [open $file_loc w] + puts $file_id "first_name,last_name,instrument" + puts $file_id "Charles,Mingus,Bass" + puts $file_id "Miles,Davis,Trumpet" + puts $file_id "Jhon,Coltrane,Saxo" + puts $file_id "Charlie,Parker,Saxo" + puts $file_id "Thelonius,Monk,Piano" + close $file_id - set artist_list {} - oacs_util::csv_foreach -file $file_loc -array_name row { + set csv_data "\nfirst_name,last_name,instrument\nCharles,Mingus,Bass\nMiles,Davis,Trumpet\nJhon,Coltrane,Saxo\nCharlie,Parker,Saxo\nThelonius,Monk,Piano" + + aa_log "CSV file created with artists data:\n $csv_data" + + set artist_list {} + oacs_util::csv_foreach -file $file_loc -array_name row { lappend artist_list "$row(first_name) $row(last_name) - $row(instrument)" } - aa_equals "Getting artists from csv file" $artist_list {{Charles Mingus - Bass}\ + aa_equals "Getting artists from csv file" $artist_list {{Charles Mingus - Bass}\ {Miles Davis - Trumpet}\ {Jhon Coltrane - Saxo}\ {Charlie Parker - Saxo}\ {Thelonius Monk - Piano}} - } -teardown_code { - file delete -force -- $file_loc + } -teardown_code { + file delete -force -- $file_loc } } @@ -60,20 +60,20 @@ puts $file_id "cparker@foo.bar,Charlie,Parker" close $file_id - set csv_data "\nemail,first_names,last_name\ncmingus@foo.bar,Charles,Mingus\nmdavis@foo.bar,Miles,Davis\ncparker@foo.bar,Charlie,Parker" + set csv_data "\nemail,first_names,last_name\ncmingus@foo.bar,Charles,Mingus\nmdavis@foo.bar,Miles,Davis\ncparker@foo.bar,Charlie,Parker" aa_log "CSV file for \"person\" objects creation with data:\n $csv_data" - set person_ids [oacs_util::process_objects_csv -object_type "person" -file $file_loc] + set person_ids [oacs_util::process_objects_csv -object_type "person" -file $file_loc] - aa_log "Persons id's created: $person_ids" + aa_log "Persons id's created: $person_ids" - set person_list {} + set person_list {} - foreach person_id $person_ids { - array set person_array [person::get -person_id $person_id] - lappend person_list "$person_array(first_names) $person_array(last_name)" - } - aa_equals "Getting persons from database table \"persons\"" $person_list {{Charles Mingus}\ + foreach person_id $person_ids { + array set person_array [person::get -person_id $person_id] + lappend person_list "$person_array(first_names) $person_array(last_name)" + } + aa_equals "Getting persons from database table \"persons\"" $person_list {{Charles Mingus}\ {Miles Davis}\ {Charlie Parker}} } -teardown_code { Index: openacs-4/packages/acs-tcl/tcl/test/test-membership-rel-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/test-membership-rel-procs.tcl,v diff -u -N -r1.6 -r1.7 --- openacs-4/packages/acs-tcl/tcl/test/test-membership-rel-procs.tcl 15 Sep 2018 16:47:35 -0000 1.6 +++ openacs-4/packages/acs-tcl/tcl/test/test-membership-rel-procs.tcl 3 Nov 2018 11:15:16 -0000 1.7 @@ -1,7 +1,7 @@ ad_library { - + Test Cases of Membership rel procs - + @author Cesar Hernandez (cesarhj@galileo.edu) @creation-date 2006-07-31 @cvs-id $Id$ @@ -24,60 +24,60 @@ } { aa_run_with_teardown -rollback -test_code { - + #we get a user_id as party_id set user_id [db_nextval acs_object_id_seq] - #Create the user + #Create the user set user_info [acs::test::user::create -user_id $user_id] - set rel_id [db_string get_rel_id "select max(rel_id) from acs_rels where object_id_two = :user_id" -default 0] + set rel_id [db_string get_rel_id "select max(rel_id) from acs_rels where object_id_two = :user_id" -default 0] - #Try to change his state to approved - aa_log "We change the state to approved" - membership_rel::approve -rel_id $rel_id + #Try to change his state to approved + aa_log "We change the state to approved" + membership_rel::approve -rel_id $rel_id acs_user::get -user_id $user_id -array user - - #Verifying if the state was changed - aa_equals "Changed State to aprroved" \ - $user(member_state) "approved" + #Verifying if the state was changed + aa_equals "Changed State to aprroved" \ + $user(member_state) "approved" - #Try to change his state to banned - aa_log "We change the state to banned" - membership_rel::ban -rel_id $rel_id - acs_user::get -user_id $user_id -array user - - #Verifying if the state was changed - aa_equals "Changed State to banned" \ - $user(member_state) "banned" + #Try to change his state to banned + aa_log "We change the state to banned" + membership_rel::ban -rel_id $rel_id + acs_user::get -user_id $user_id -array user - #Try to change his state to rejected - aa_log "We change the state to rejected" - membership_rel::reject -rel_id $rel_id - acs_user::get -user_id $user_id -array user - - #Verifying if the state was changed - aa_equals "Changed State to rejected" \ - $user(member_state) "rejected" + #Verifying if the state was changed + aa_equals "Changed State to banned" \ + $user(member_state) "banned" - #Try to change his state to unapproved - aa_log "We change the state to unapproved" - membership_rel::unapprove -rel_id $rel_id - acs_user::get -user_id $user_id -array user + #Try to change his state to rejected + aa_log "We change the state to rejected" + membership_rel::reject -rel_id $rel_id + acs_user::get -user_id $user_id -array user - #Verifying if the state was changed - aa_equals "Changed State to unapproved" \ - $user(member_state) "needs approval" + #Verifying if the state was changed + aa_equals "Changed State to rejected" \ + $user(member_state) "rejected" - #Try to change his state to deleted - aa_log "We change the state to deleted" + + #Try to change his state to unapproved + aa_log "We change the state to unapproved" + membership_rel::unapprove -rel_id $rel_id + acs_user::get -user_id $user_id -array user + + #Verifying if the state was changed + aa_equals "Changed State to unapproved" \ + $user(member_state) "needs approval" + + #Try to change his state to deleted + aa_log "We change the state to deleted" membership_rel::delete -rel_id $rel_id acs_user::get -user_id $user_id -array user - #Verifying if the state was changed - aa_equals "Changed State to deleted" \ + #Verifying if the state was changed + aa_equals "Changed State to deleted" \ $user(member_state) "deleted" } } Index: openacs-4/packages/acs-tcl/tcl/test/test-set-cookie-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/test-set-cookie-procs.tcl,v diff -u -N -r1.5 -r1.6 --- openacs-4/packages/acs-tcl/tcl/test/test-set-cookie-procs.tcl 25 Jul 2018 13:42:48 -0000 1.5 +++ openacs-4/packages/acs-tcl/tcl/test/test-set-cookie-procs.tcl 3 Nov 2018 11:15:16 -0000 1.6 @@ -1,7 +1,7 @@ ad_library { - + Test Case for set_cookie procs - + @author Cesar Hernandez (cesarhj@galileo.edu) @creation-date 2006-08-10 @cvs-id $Id$ @@ -16,62 +16,62 @@ } \ test_set_cookie_procs \ { - Test Case for testing if a cookie is fixed + Test Case for testing if a cookie is fixed } { - #----------------------------------------------------------------------------- - #Set values for default - #----------------------------------------------------------------------------- - set data [ad_generate_random_string] + #----------------------------------------------------------------------------- + #Set values for default + #----------------------------------------------------------------------------- + set data [ad_generate_random_string] - aa_log "The content of the cookie is: $data" + aa_log "The content of the cookie is: $data" - aa_run_with_teardown -test_code { + aa_run_with_teardown -test_code { - #------------------------------------------------------------------------- - #set the cookie - #------------------------------------------------------------------------- - ad_set_cookie "test_cookie_test_case" "$data" + #------------------------------------------------------------------------- + #set the cookie + #------------------------------------------------------------------------- + ad_set_cookie "test_cookie_test_case" "$data" - #------------------------------------------------------------------------- - #Get the cookie and we try if exist - #------------------------------------------------------------------------- - set cookie_info_p [ad_get_cookie -include_set_cookies t test_cookie_test_case "" ] - aa_equals "Check if the cookie exist" $cookie_info_p $data + #------------------------------------------------------------------------- + #Get the cookie and we try if exist + #------------------------------------------------------------------------- + set cookie_info_p [ad_get_cookie -include_set_cookies t test_cookie_test_case "" ] + aa_equals "Check if the cookie exist" $cookie_info_p $data - #------------------------------------------------------------------------- - #clearing the cookie - #------------------------------------------------------------------------- - ad_set_cookie -replace t -max_age 0 test_cookie_test_case "" - set cookie_info_d [ad_get_cookie -include_set_cookies t test_cookie_test_case ""] + #------------------------------------------------------------------------- + #clearing the cookie + #------------------------------------------------------------------------- + ad_set_cookie -replace t -max_age 0 test_cookie_test_case "" + set cookie_info_d [ad_get_cookie -include_set_cookies t test_cookie_test_case ""] - #------------------------------------------------------------------------- - #Check if the cookie was cleared - #------------------------------------------------------------------------- - aa_false "Check if the cookie was cleared" [string equal $cookie_info_d $data] + #------------------------------------------------------------------------- + #Check if the cookie was cleared + #------------------------------------------------------------------------- + aa_false "Check if the cookie was cleared" [string equal $cookie_info_d $data] - # known secret - ad_set_signed_cookie -secret "hello" -max_age 100 -token_id 101 testcookie "as,df" - # random secret - ad_set_signed_cookie -max_age 1 testcookie2 "lots,of,,commas" + # known secret + ad_set_signed_cookie -secret "hello" -max_age 100 -token_id 101 testcookie "as,df" + # random secret + ad_set_signed_cookie -max_age 1 testcookie2 "lots,of,,commas" - #set cookie_value [ad_get_signed_cookie testcookie] - set cookie_value [ns_urldecode [ad_get_cookie testcookie]] + #set cookie_value [ad_get_signed_cookie testcookie] + set cookie_value [ns_urldecode [ad_get_cookie testcookie]] - aa_equals "cookie payload" "as,df" [lindex $cookie_value 0] + aa_equals "cookie payload" "as,df" [lindex $cookie_value 0] - set cookie_meta [lindex $cookie_value 1] + set cookie_meta [lindex $cookie_value 1] - aa_equals "cookie meta length" 3 [llength $cookie_meta] + aa_equals "cookie meta length" 3 [llength $cookie_meta] - lassign $cookie_meta token_id expire hash + lassign $cookie_meta token_id expire hash - aa_equals "cookie meta token_id" 101 $token_id + aa_equals "cookie meta token_id" 101 $token_id - } -teardown_code { + } -teardown_code { - } + } } aa_register_case \ @@ -82,14 +82,14 @@ } \ client_properties \ { - Test Case client properties + Test Case client properties } { - aa_run_with_teardown -test_code { - ad_set_client_property test MyName MyValue + aa_run_with_teardown -test_code { + ad_set_client_property test MyName MyValue - aa_equals "Obtain client property" MyValue [ad_get_client_property test MyName] - - } + aa_equals "Obtain client property" MyValue [ad_get_client_property test MyName] + + } } # Local variables: # mode: tcl Index: openacs-4/packages/acs-tcl/tcl/test/whos-online-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/whos-online-procs.tcl,v diff -u -N -r1.9 -r1.10 --- openacs-4/packages/acs-tcl/tcl/test/whos-online-procs.tcl 25 Jul 2018 13:42:48 -0000 1.9 +++ openacs-4/packages/acs-tcl/tcl/test/whos-online-procs.tcl 3 Nov 2018 11:15:16 -0000 1.10 @@ -1,6 +1,6 @@ ad_library { Check whos-online procs - + @author Juan Pablo Amaya jpamaya@unicauca.edu.co @creation-date 2006-08-02 } @@ -14,67 +14,67 @@ whos_online::unset_invisible whos_online::user_ids } whos_online__check_online_visibility { - + Check procs related with users online visibility } { - + set user_id [db_nextval acs_object_id_seq] - + aa_run_with_teardown -test_code { - + #--------------------------------------------------------------------------------------------------- - #Test num_users + #Test num_users #--------------------------------------------------------------------------------------------------- - + set logged_users [whos_online::num_users] aa_log "Logged users: $logged_users" - + # Login user set user_info [acs::test::user::create -admin -user_id $user_id] set d [acs::test::http -user_id $user_id /] - set logged_users [whos_online::num_users] - aa_true "New user logged - Users logged: $logged_users" { $logged_users > 0 } - + set logged_users [whos_online::num_users] + aa_true "New user logged - Users logged: $logged_users" { $logged_users > 0 } + #--------------------------------------------------------------------------------------------------- - #Test set_invisible + #Test set_invisible #--------------------------------------------------------------------------------------------------- - - aa_log "User [dict get $user_info email] is visible" - - whos_online::set_invisible $user_id - - aa_true "User [dict get $user_info email] is Invisible" {[nsv_exists invisible_users $user_id] == 1 } - + + aa_log "User [dict get $user_info email] is visible" + + whos_online::set_invisible $user_id + + aa_true "User [dict get $user_info email] is Invisible" {[nsv_exists invisible_users $user_id] == 1 } + #--------------------------------------------------------------------------------------------------- #Test all-invisible_user_ids #--------------------------------------------------------------------------------------------------- aa_true "User [dict get $user_info email] user_id $user_id is in the invisible list ([whos_online::all_invisible_user_ids])" \ - {$user_id in [whos_online::all_invisible_user_ids]} - + {$user_id in [whos_online::all_invisible_user_ids]} + #--------------------------------------------------------------------------------------------------- - #Test unset_invisible + #Test unset_invisible #--------------------------------------------------------------------------------------------------- - - aa_log "User [dict get $user_info email] is invisible" - - whos_online::unset_invisible $user_id - - aa_false "User [dict get $user_info email] is Visible" \ - {[whos_online::user_invisible_p $user_id ] == 1 } - + + aa_log "User [dict get $user_info email] is invisible" + + whos_online::unset_invisible $user_id + + aa_false "User [dict get $user_info email] is Visible" \ + {[whos_online::user_invisible_p $user_id ] == 1 } + #--------------------------------------------------------------------------------------------------- #Test user_ids #--------------------------------------------------------------------------------------------------- - - aa_true "User [dict get $user_info email] user_id $user_id is in the visible list ([whos_online::user_ids])" \ - {$user_id in [whos_online::user_ids]} + aa_true "User [dict get $user_info email] user_id $user_id is in the visible list ([whos_online::user_ids])" \ + {$user_id in [whos_online::user_ids]} + } -teardown_code { - acs::test::user::delete -user_id $user_id + acs::test::user::delete -user_id $user_id } }