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 -r1.3 -r1.4 --- openacs-4/packages/acs-tcl/tcl/test/acs-tcl-test-procs.tcl 4 Apr 2003 09:49:38 -0000 1.3 +++ openacs-4/packages/acs-tcl/tcl/test/acs-tcl-test-procs.tcl 10 Sep 2003 08:09:42 -0000 1.4 @@ -22,3 +22,226 @@ puts $file_id "$arg1 $arg2" close $file_id } + + +aa_register_case util__sets_equal_p { + Test the util_sets_equal_p proc. + + @author Peter Marklund +} { + aa_true "lists are identical sets" [util_sets_equal_p [list a a a b b c] [list c a a b b a]] + aa_true "lists are identical sets 2" [util_sets_equal_p [list a b c] [list a b c]] + aa_false "lists are not identical sets" [util_sets_equal_p [list a a a b b c] [list c c a b b a]] + aa_false "lists are not identical sets 2" [util_sets_equal_p [list a b c] [list a b c d]] +} + +# By stubbing this proc we can define callbacks valid only during testing +# that are guaranteed not to interfere with any real callbacks in the system +aa_stub apm_supported_callback_types { + return [list __test-callback-type] +} + +aa_stub apm_arg_names_for_callback_type { + return [list arg1 arg2] +} + +aa_register_case apm__test_info_file { + Test that the procs for interfacing with package info files - + apm_generate_package_spec and + apm_read_package_info_file - handle the newly added + callback and auto-mount tags properly. + + @creation-date 22 January 2003 + @author Peter Marklund +} { + set test_dir "[acs_package_root_dir acs-tcl]/tcl/test" + set spec_path "${test_dir}/tmp-test-info-file.xml" + set allowed_type [lindex [apm_supported_callback_types] 0] + array set callback_array [list unknown-type proc_name1 $allowed_type proc_name2] + set version_id [db_string aa_version_id {select version_id + from apm_enabled_package_versions + where package_key = 'acs-automated-testing'}] + set auto_mount_orig [db_string aa_auto_mount {select auto_mount + from apm_package_versions + where version_id = :version_id}] + set auto_mount $auto_mount_orig + if { [empty_string_p $auto_mount] } { + set auto_mount "test_auto_mount_dir" + db_dml set_test_mount {update apm_package_versions + set auto_mount = :auto_mount + where version_id = :version_id} + } + + set error_p [catch { + # Add a few test callbacks + foreach {type proc} [array get callback_array] { + db_dml insert_callback {insert into apm_package_callbacks + (version_id, type, proc) + values (:version_id, :type, :proc)} + } + + # Get the xml string + set spec [apm_generate_package_spec $version_id] + + # Write xml to file + set spec_file_id [open $spec_path w] + puts $spec_file_id $spec + close $spec_file_id + + # Read the xml file + array set spec_array [apm_read_package_info_file $spec_path] + + # Assert that info parsed from xml file is correct + array set parsed_callback_array $spec_array(callbacks) + + aa_true "Only one permissible callback should be returned, got array [array get parsed_callback_array]" \ + [expr [llength [array names parsed_callback_array]] == 1] + + aa_equals "Checking name of callback of allowed type $allowed_type" \ + $parsed_callback_array($allowed_type) $callback_array($allowed_type) + + aa_equals "Checking that auto-callback is correct" $spec_array(auto-mount) $auto_mount + + } error] + + # Teardown + file delete $spec_path + foreach {type proc} [array get callback_array] { + db_dml remove_callback {delete from apm_package_callbacks + where version_id = :version_id + and type = :type } + } + db_dml reset_auto_mount {update apm_package_versions + set auto_mount = :auto_mount_orig + where version_id = :version_id} + + + if { $error_p } { + global errorInfo + error "$error - $errorInfo" + } +} + +aa_register_case apm__test_callback_get_set { + Test the procs apm_get_callback_proc, + apm_set_callback_proc, + apm_package_install_callbacks + apm_remove_callback_proc, + apm_post_instantiation_tcl_proc_from_key. + + @author Peter Marklund +} { + # The proc should not accept an invalid callback type + set invalid_type "not-allowed-type" + set error_p [catch {apm_get_callback_proc -type $invalid_type -package_key acs-kernel} error] + aa_true "invalid types should result in error, got error: $error" $error_p + + # Try setting a package callback proc + set callback_type [lindex [apm_supported_callback_types] 0] + set proc_name "test_proc" + set package_key "acs-automated-testing" + set version_id [apm_version_id_from_package_key $package_key] + + set error_p [catch { + apm_package_install_callbacks [list $callback_type $proc_name] $version_id + + # Retrieve the callback proc + set retrieved_proc_name \ + [apm_get_callback_proc -package_key $package_key \ + -type $callback_type] + aa_equals "apm_get_callback_proc retrieve callback proc" \ + $retrieved_proc_name $proc_name + } error] + + # Teardown + apm_remove_callback_proc -package_key $package_key -type $callback_type + + if { $error_p } { + global errorInfo + error "$error - $errorInfo" + } +} + +aa_register_case apm__test_callback_invoke { + Test the proc apm_invoke_callback_proc + + @author Peter Marklund +} { + set package_key acs-automated-testing + set version_id [apm_version_id_from_package_key $package_key] + set type [lindex [apm_supported_callback_types] 0] + set file_path [apm_test_callback_file_path] + + set error_p [catch { + + # Set the callback to be to our little test proc + apm_set_callback_proc -version_id $version_id -type $type "apm_test_callback_proc" + + apm_invoke_callback_proc -version_id $version_id -arg_list [list arg1 value1 arg2 value2] -type $type + + set file_id [open $file_path r] + set file_contents [read $file_id] + aa_equals "The callback proc should have been executed and written argument values to file" \ + [string trim $file_contents] "value1 value2" + close $file_id + + # Provide invalid argument list and the invoke proc should bomb + # TODO... + } error] + + # Teardown + file delete $file_path + apm_remove_callback_proc -package_key $package_key -type $type + + if { $error_p } { + global errorInfo + error "$error - $errorInfo" + } +} + +aa_register_case xml_get_child_node_content_by_path { + Test xml_get_child_node_content_by_path +} { + set tree [xml_parse -persist { + + + Dunelm Services Limited + Telecommunications LMS + DATABASE UPDATE + 2001-08-08 + + + Add a new Person record. + + Dunelm Services Limited + CK1 + + + Clark Kent + Kent, C + Superman + + + 2 + + + The Daily Planet + Metropolis + USA + + + + }] + + set root_node [xml_doc_get_first_node $tree] + + aa_equals "person -> name -> nickname is Superman" \ + [xml_get_child_node_content_by_path $root_node { { person name nickname } }] "Superman" + + aa_equals "Same, but after trying a couple of non-existent paths or empty notes" \ + [xml_get_child_node_content_by_path $root_node { { does not exist } { properties } { person name nickname } { person sourcedid id } }] "Superman" + aa_equals "properties -> datetime" \ + [xml_get_child_node_content_by_path $root_node { { person commments foo } { person name first_names } { properties datetime } }] "2001-08-08" + + +}