Index: openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl,v diff -u -r1.32 -r1.33 --- openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl 29 Aug 2003 13:34:42 -0000 1.32 +++ openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl 4 Sep 2003 07:40:43 -0000 1.33 @@ -9,501 +9,501 @@ } -namespace eval site_node { +namespace eval site_node {} - ad_proc -public new { - {-name:required} - {-parent_id:required} - {-directory_p t} - {-pattern_p t} - } { - create a new site node - } { - set extra_vars [ns_set create] - ns_set put $extra_vars name $name - ns_set put $extra_vars parent_id $parent_id - ns_set put $extra_vars directory_p $directory_p - ns_set put $extra_vars pattern_p $pattern_p +ad_proc -public site_node::new { + {-name:required} + {-parent_id:required} + {-directory_p t} + {-pattern_p t} +} { + create a new site node +} { + set extra_vars [ns_set create] + ns_set put $extra_vars name $name + ns_set put $extra_vars parent_id $parent_id + ns_set put $extra_vars directory_p $directory_p + ns_set put $extra_vars pattern_p $pattern_p - set node_id [package_instantiate_object -extra_vars $extra_vars site_node] + set node_id [package_instantiate_object -extra_vars $extra_vars site_node] - update_cache -node_id $node_id + update_cache -node_id $node_id - return $node_id - } + return $node_id +} - ad_proc -public delete { - {-node_id:required} - } { - delete the site node - } { - db_exec_plsql delete_site_node {} - update_cache -node_id $node_id +ad_proc -public site_node::delete { + {-node_id:required} +} { + delete the site node +} { + db_exec_plsql delete_site_node {} + update_cache -node_id $node_id +} + +ad_proc -public site_node::mount { + {-node_id:required} + {-object_id:required} +} { + mount object at site node +} { + db_dml mount_object {} + update_cache -node_id $node_id + + apm_invoke_callback_proc -package_key [apm_package_key_from_id $object_id] -type "after-mount" -arg_list [list node_id $node_id package_id $object_id] +} + +ad_proc -public site_node::rename { + {-node_id:required} + {-name:required} +} { + Rename the site node. +} { + # We need to update the cache for all the child nodes as well + set node_url [get_url -node_id $node_id] + set child_node_ids [get_children -all -node_id $node_id -element node_id] + + db_dml rename_node {} + + # Unset all cache entries under the old path + foreach name [nsv_array names site_nodes "${node_url}*"] { + nsv_unset site_nodes $name } - ad_proc -public mount { - {-node_id:required} - {-object_id:required} - } { - mount object at site node - } { - db_dml mount_object {} + foreach node_id [concat $node_id $child_node_ids] { update_cache -node_id $node_id - - apm_invoke_callback_proc -package_key [apm_package_key_from_id $object_id] -type "after-mount" -arg_list [list node_id $node_id package_id $object_id] } +} - ad_proc -public rename { - {-node_id:required} - {-name:required} - } { - Rename the site node. - } { - # We need to update the cache for all the child nodes as well - set node_url [get_url -node_id $node_id] - set child_node_ids [get_children -all -node_id $node_id -element node_id] +ad_proc -public site_node::instantiate_and_mount { + {-node_id ""} + {-parent_node_id ""} + {-node_name ""} + {-package_name ""} + {-context_id ""} + {-package_key:required} + {-package_id ""} +} { + Instantiate and mount a package of given type. Will use an existing site node if possible. - db_dml rename_node {} + @param node_id The id of the node in the site map where the package should be mounted. + @param parent_node_id If no node_id is specified this will be the parent node under which the + new node is created. Defaults to the main site node id. + @param node_name If node_id is not specified then this will be the name of the + new site node that is created. Defaults to package_key. + @param package_name The name of the new package instance. Defaults to pretty name of package type. + @param context_id The context_id of the package. Defaults to the closest ancestor package + in the site map. + @param package_key The key of the package type to instantiate. + @param package_id The id of the new package. Optional. - # Unset all cache entries under the old path - foreach name [nsv_array names site_nodes "${node_url}*"] { - nsv_unset site_nodes $name + @return The id of the instantiated package + + @author Peter Marklund +} { + # Create a new node if none was provided and none exists + if { [empty_string_p $node_id] } { + # Default parent node to the main site + if { [empty_string_p $parent_node_id ] } { + set parent_node_id [site_node::get_node_id -url "/"] } - foreach node_id [concat $node_id $child_node_ids] { - update_cache -node_id $node_id - } - } + # Default node_name to package_key + set node_name [ad_decode $node_name "" $package_key $node_name] - ad_proc -public instantiate_and_mount { - {-node_id ""} - {-parent_node_id ""} - {-node_name ""} - {-package_name ""} - {-context_id ""} - {-package_key:required} - {-package_id ""} - } { - Instantiate and mount a package of given type. Will use an existing site node if possible. + # Create the node if it doesn't exists + set parent_url [get_url -notrailing -node_id $parent_node_id] + set url "${parent_url}/${node_name}" - @param node_id The id of the node in the site map where the package should be mounted. - @param parent_node_id If no node_id is specified this will be the parent node under which the - new node is created. Defaults to the main site node id. - @param node_name If node_id is not specified then this will be the name of the - new site node that is created. Defaults to package_key. - @param package_name The name of the new package instance. Defaults to pretty name of package type. - @param context_id The context_id of the package. Defaults to the closest ancestor package - in the site map. - @param package_key The key of the package type to instantiate. - @param package_id The id of the new package. Optional. + if { ![exists_p -url $url] } { + set node_id [site_node::new -name $node_name -parent_id $parent_node_id] + } else { + # Check that there isn't already a package mounted at the node + array set node [get -url $url] - @return The id of the instantiated package - - @author Peter Marklund - } { - # Create a new node if none was provided and none exists - if { [empty_string_p $node_id] } { - # Default parent node to the main site - if { [empty_string_p $parent_node_id ] } { - set parent_node_id [site_node::get_node_id -url "/"] + if { [exists_and_not_null node(object_id)] } { + error "Cannot mount package at url $url as package $node(object_id) is already mounted there" } - # Default node_name to package_key - set node_name [ad_decode $node_name "" $package_key $node_name] + set node_id $node(node_id) + } + } - # Create the node if it doesn't exists - set parent_url [get_url -notrailing -node_id $parent_node_id] - set url "${parent_url}/${node_name}" + # Default context id to the closest ancestor package_id + if {[empty_string_p $context_id]} { + set context_id [site_node::closest_ancestor_package -node_id $node_id] + } - if { ![exists_p -url $url] } { - set node_id [site_node::new -name $node_name -parent_id $parent_node_id] - } else { - # Check that there isn't already a package mounted at the node - array set node [get -url $url] + # Instantiate the package + set package_id [apm_package_instance_new -package_id $package_id \ + -package_key $package_key \ + -instance_name $package_name \ + -context_id $context_id] - if { [exists_and_not_null node(object_id)] } { - error "Cannot mount package at url $url as package $node(object_id) is already mounted there" - } + # Mount the package + site_node::mount -node_id $node_id -object_id $package_id - set node_id $node(node_id) - } - } + return $package_id +} - # Default context id to the closest ancestor package_id - if {[empty_string_p $context_id]} { - set context_id [site_node::closest_ancestor_package -node_id $node_id] - } +ad_proc -public site_node::unmount { + {-node_id:required} +} { + unmount an object from the site node +} { + set package_id [get_object_id -node_id $node_id] + apm_invoke_callback_proc -package_key [apm_package_key_from_id $package_id] -type before-unmount -arg_list [list package_id $package_id node_id $node_id] - # Instantiate the package - set package_id [apm_package_instance_new -package_id $package_id \ - -package_key $package_key \ - -instance_name $package_name \ - -context_id $context_id] + db_dml unmount_object {} + update_cache -node_id $node_id +} - # Mount the package - site_node::mount -node_id $node_id -object_id $package_id +ad_proc -private site_node::init_cache {} { + initialize the site node cache +} { + nsv_array reset site_nodes [list] + nsv_array reset site_node_urls [list] - return $package_id + db_foreach select_site_nodes {} -column_array node { + nsv_set site_nodes $node(url) [array get node] + nsv_set site_node_urls $node(node_id) $node(url) } - ad_proc -public unmount { - {-node_id:required} - } { - unmount an object from the site node - } { - set package_id [get_object_id -node_id $node_id] - apm_invoke_callback_proc -package_key [apm_package_key_from_id $package_id] -type before-unmount -arg_list [list package_id $package_id node_id $node_id] +} - db_dml unmount_object {} - update_cache -node_id $node_id - } +ad_proc -private site_node::update_cache { + {-node_id:required} +} { + if { [db_0or1row select_site_node {} -column_array node] } { + nsv_set site_nodes $node(url) [array get node] + nsv_set site_node_urls $node(node_id) $node(url) - ad_proc -private init_cache {} { - initialize the site node cache - } { - nsv_array reset site_nodes [list] - nsv_array reset site_node_urls [list] + } else { + set url [get_url -node_id $node_id] - db_foreach select_site_nodes {} -column_array node { - nsv_set site_nodes $node(url) [array get node] - nsv_set site_node_urls $node(node_id) $node(url) + if {[nsv_exists site_nodes $url]} { + nsv_unset site_nodes $url } + if {[nsv_exists site_node_urls $node_id]} { + nsv_unset site_node_urls $node_id + } } +} - ad_proc -private update_cache { - {-node_id:required} - } { - if { [db_0or1row select_site_node {} -column_array node] } { - nsv_set site_nodes $node(url) [array get node] - nsv_set site_node_urls $node(node_id) $node(url) +ad_proc -public site_node::get { + {-url ""} + {-node_id ""} +} { + returns an array representing the site node that matches the given url - } else { - set url [get_url -node_id $node_id] + either url or node_id is required, if both are passed url is ignored - if {[nsv_exists site_nodes $url]} { - nsv_unset site_nodes $url - } + The array elements are: package_id, package_key, object_type, directory_p, + instance_name, pattern_p, parent_id, node_id, object_id, url. +} { + if {[empty_string_p $url] && [empty_string_p $node_id]} { + error "site_node::get \"must pass in either url or node_id\"" + } - if {[nsv_exists site_node_urls $node_id]} { - nsv_unset site_node_urls $node_id - } - } + if {![empty_string_p $node_id]} { + return [get_from_node_id -node_id $node_id] } - ad_proc -public get { - {-url ""} - {-node_id ""} - } { - returns an array representing the site node that matches the given url + if {![empty_string_p $url]} { + return [get_from_url -url $url] + } - either url or node_id is required, if both are passed url is ignored +} - The array elements are: package_id, package_key, object_type, directory_p, - instance_name, pattern_p, parent_id, node_id, object_id, url. - } { - if {[empty_string_p $url] && [empty_string_p $node_id]} { - error "site_node::get \"must pass in either url or node_id\"" - } +ad_proc -public site_node::get_from_node_id { + {-node_id:required} +} { + returns an array representing the site node for the given node_id + + @see site_node::get +} { + return [get_from_url -url [get_url -node_id $node_id]] +} - if {![empty_string_p $node_id]} { - return [get_from_node_id -node_id $node_id] - } +ad_proc -public site_node::get_from_url { + {-url:required} + {-exact:boolean} +} { + Returns an array representing the site node that matches the given url.

- if {![empty_string_p $url]} { - return [get_from_url -url $url] - } + A trailing '/' will be appended to $url if required and not present.

- } + If the '-exact' switch is not present and $url is not found, returns the + first match found by successively removing the trailing $url path component.

- ad_proc -public get_from_node_id { - {-node_id:required} - } { - returns an array representing the site node for the given node_id - - @see site_node::get - } { - return [get_from_url -url [get_url -node_id $node_id]] + @see site_node::get +} { + # attempt an exact match + if {[nsv_exists site_nodes $url]} { + return [nsv_get site_nodes $url] } - ad_proc -public get_from_url { - {-url:required} - {-exact:boolean} - } { - Returns an array representing the site node that matches the given url.

- - A trailing '/' will be appended to $url if required and not present.

- - If the '-exact' switch is not present and $url is not found, returns the - first match found by successively removing the trailing $url path component.

- - @see site_node::get - } { - # attempt an exact match + # attempt adding a / to the end of the url if it doesn't already have + # one + if {![string equal [string index $url end] "/"]} { + append url "/" if {[nsv_exists site_nodes $url]} { return [nsv_get site_nodes $url] } + } - # attempt adding a / to the end of the url if it doesn't already have - # one - if {![string equal [string index $url end] "/"]} { - append url "/" - if {[nsv_exists site_nodes $url]} { - return [nsv_get site_nodes $url] - } - } + # chomp off part of the url and re-attempt + if {!$exact_p} { + while {![empty_string_p $url]} { + set url [string trimright $url /] + set url [string range $url 0 [string last / $url]] - # chomp off part of the url and re-attempt - if {!$exact_p} { - while {![empty_string_p $url]} { - set url [string trimright $url /] - set url [string range $url 0 [string last / $url]] + if {[nsv_exists site_nodes $url]} { + array set node [nsv_get site_nodes $url] - if {[nsv_exists site_nodes $url]} { - array set node [nsv_get site_nodes $url] - - if {[string equal $node(pattern_p) t] && ![empty_string_p $node(object_id)]} { - return [array get node] - } - } - } - } - - error "site node not found at url \"$url\"" + if {[string equal $node(pattern_p) t] && ![empty_string_p $node(object_id)]} { + return [array get node] + } + } + } } - ad_proc -public exists_p { - {-url:required} - } { - Returns 1 if a site node exists at the given url and 0 otherwise. + error "site node not found at url \"$url\"" +} - @author Peter Marklund - } { - set url_no_trailing [string trimright $url "/"] - return [nsv_exists site_nodes "$url_no_trailing/"] - } +ad_proc -public site_node::exists_p { + {-url:required} +} { + Returns 1 if a site node exists at the given url and 0 otherwise. - ad_proc -public get_from_object_id { - {-object_id:required} - } { - return the site node associated with the given object_id + @author Peter Marklund +} { + set url_no_trailing [string trimright $url "/"] + return [nsv_exists site_nodes "$url_no_trailing/"] +} - WARNING: Returns only the first site node associated with this object. - } { - return [get -url [lindex [get_url_from_object_id -object_id $object_id] 0]] - } +ad_proc -public site_node::get_from_object_id { + {-object_id:required} +} { + return the site node associated with the given object_id - ad_proc -public get_all_from_object_id { - {-object_id:required} - } { - Return a list of site node info associated with the given object_id. - The nodes will be ordered descendingly by url (children before their parents). - } { - set node_id_list [list] + WARNING: Returns only the first site node associated with this object. +} { + return [get -url [lindex [get_url_from_object_id -object_id $object_id] 0]] +} - set url_list [list] - foreach url [get_url_from_object_id -object_id $object_id] { - lappend node_id_list [get -url $url] - } +ad_proc -public site_node::get_all_from_object_id { + {-object_id:required} +} { + Return a list of site node info associated with the given object_id. + The nodes will be ordered descendingly by url (children before their parents). +} { + set node_id_list [list] - return $node_id_list + set url_list [list] + foreach url [get_url_from_object_id -object_id $object_id] { + lappend node_id_list [get -url $url] } - ad_proc -public get_url { - {-node_id:required} - {-notrailing:boolean} - } { - return the url of this node_id + return $node_id_list +} - @notrailing If true then strip any - trailing slash ('/'). This means the empty string is returned for the root. - } { - set url "" - if {[nsv_exists site_node_urls $node_id]} { - set url [nsv_get site_node_urls $node_id] - } - - if { $notrailing_p } { - set url [string trimright $url "/"] - } +ad_proc -public site_node::get_url { + {-node_id:required} + {-notrailing:boolean} +} { + return the url of this node_id - return $url + @notrailing If true then strip any + trailing slash ('/'). This means the empty string is returned for the root. +} { + set url "" + if {[nsv_exists site_node_urls $node_id]} { + set url [nsv_get site_node_urls $node_id] } - - ad_proc -public get_url_from_object_id { - {-object_id:required} - } { - returns a list of urls for site_nodes that have the given object - mounted or the empty list if there are none. The - url:s will be returned in descending order meaning any children will - come before their parents. This ordering is useful when deleting site nodes - as we must delete child site nodes before their parents. - } { - return [db_list select_url_from_object_id {}] + + if { $notrailing_p } { + set url [string trimright $url "/"] } - ad_proc -public get_node_id { - {-url:required} - } { - return the node_id for this url - } { - array set node [get -url $url] - return $node(node_id) - } + return $url +} - ad_proc -public get_node_id_from_object_id { - {-object_id:required} - } { - return the site node id associated with the given object_id - } { - return [get_node_id -url [lindex [get_url_from_object_id -object_id $object_id] 0]] - } +ad_proc -public site_node::get_url_from_object_id { + {-object_id:required} +} { + returns a list of urls for site_nodes that have the given object + mounted or the empty list if there are none. The + url:s will be returned in descending order meaning any children will + come before their parents. This ordering is useful when deleting site nodes + as we must delete child site nodes before their parents. +} { + return [db_list select_url_from_object_id {}] +} - ad_proc -public get_parent_id { - {-node_id:required} - } { - return the parent_id of this node - } { - array set node [get -node_id $node_id] - return $node(parent_id) - } +ad_proc -public site_node::get_node_id { + {-url:required} +} { + return the node_id for this url +} { + array set node [get -url $url] + return $node(node_id) +} - ad_proc -public get_parent { - {-node_id:required} - } { - return the parent node of this node - } { - array set node [get -node_id $node_id] - return [get -node_id $node(parent_id)] - } +ad_proc -public site_node::get_node_id_from_object_id { + {-object_id:required} +} { + return the site node id associated with the given object_id +} { + return [get_node_id -url [lindex [get_url_from_object_id -object_id $object_id] 0]] +} - ad_proc -public get_object_id { - {-node_id:required} - } { - return the object_id for this node - } { - array set node [get -node_id $node_id] - return $node(object_id) - } +ad_proc -public site_node::get_parent_id { + {-node_id:required} +} { + return the parent_id of this node +} { + array set node [get -node_id $node_id] + return $node(parent_id) +} - ad_proc -public get_children { - {-all:boolean} - {-package_type {}} - {-element {}} - {-node_id:required} - } { - @param node_id The node for which you want to find the children. +ad_proc -public site_node::get_parent { + {-node_id:required} +} { + return the parent node of this node +} { + array set node [get -node_id $node_id] + return [get -node_id $node(parent_id)] +} - @option all Set this if you want all children, not just direct children - - @option package_type If specified, this will limit the returned nodes to those with an - package of the specified package type (normally apm_service or - apm_application) mounted - - @param element The element of the site node you wish returned. Defaults to url, but you - can say 'node_id' instead. - - @return A list of URLs of the site_nodes immediately under this site node, or all children, - if the -all switch is specified. - - @author Lars Pind (lars@collaboraid.biz) - } { - set node_url [get_url -node_id $node_id] - - set child_urls [nsv_array names site_nodes "${node_url}*"] +ad_proc -public site_node::get_object_id { + {-node_id:required} +} { + return the object_id for this node +} { + array set node [get -node_id $node_id] + return $node(object_id) +} - if { !$all_p } { - set org_child_urls $child_urls - set child_urls [list] - foreach child_url $org_child_urls { - if { [regexp "^${node_url}\[^/\]*/\$" $child_url] } { - lappend child_urls $child_url - } +ad_proc -public site_node::get_children { + {-all:boolean} + {-package_type {}} + {-element {}} + {-node_id:required} +} { + @param node_id The node for which you want to find the children. + + @option all Set this if you want all children, not just direct children + + @option package_type If specified, this will limit the returned nodes to those with an + package of the specified package type (normally apm_service or + apm_application) mounted + + @param element The element of the site node you wish returned. Defaults to url, but you + can say 'node_id' instead. + + @return A list of URLs of the site_nodes immediately under this site node, or all children, + if the -all switch is specified. + + @author Lars Pind (lars@collaboraid.biz) +} { + set node_url [get_url -node_id $node_id] + + set child_urls [nsv_array names site_nodes "${node_url}*"] + + if { !$all_p } { + set org_child_urls $child_urls + set child_urls [list] + foreach child_url $org_child_urls { + if { [regexp "^${node_url}\[^/\]*/\$" $child_url] } { + lappend child_urls $child_url } } + } - if { ![empty_string_p $package_type] } { - set org_child_urls $child_urls - set child_urls [list] - foreach child_url $org_child_urls { - array unset site_node - array set site_node [get_from_url -exact -url $child_url] + if { ![empty_string_p $package_type] } { + set org_child_urls $child_urls + set child_urls [list] + foreach child_url $org_child_urls { + array unset site_node + array set site_node [get_from_url -exact -url $child_url] - if { [string equal $site_node(package_type) $package_type] } { - lappend child_urls $child_url - } + if { [string equal $site_node(package_type) $package_type] } { + lappend child_urls $child_url } } + } - if { ![empty_string_p $element] } { - # We need to update the cache for all the child nodes as well - set return_val [list] - foreach child_url $child_urls { - array unset site_node - array set site_node [site_node::get_from_url -url $child_url] + if { ![empty_string_p $element] } { + # We need to update the cache for all the child nodes as well + set return_val [list] + foreach child_url $child_urls { + array unset site_node + array set site_node [site_node::get_from_url -url $child_url] - lappend return_val $site_node($element) - } - return $return_val - } else { - return $child_urls + lappend return_val $site_node($element) } + return $return_val + } else { + return $child_urls } +} - ad_proc -public closest_ancestor_package { - {-url ""} - {-node_id ""} - {-package_key ""} - } { - Starting with the node at with given id, or at given url, - climb up the site map and return the id of the first not-null - mounted object. If no ancestor object is found the empty string is returned. - The id of the object at the given node itself will never be returned. +ad_proc -public site_node::closest_ancestor_package { + {-url ""} + {-node_id ""} + {-package_key ""} +} { + Starting with the node at with given id, or at given url, + climb up the site map and return the id of the first not-null + mounted object. If no ancestor object is found the empty string is returned. + The id of the object at the given node itself will never be returned. - @param url The url of the node to start from. You must provide either url or node_id. - An empty url is taken to mean the main site. - @param node_id The id of the node to start from. Takes precedence over any provided url. - @param package_key Restrict search to objects of this package type. + @param url The url of the node to start from. You must provide either url or node_id. + An empty url is taken to mean the main site. + @param node_id The id of the node to start from. Takes precedence over any provided url. + @param package_key Restrict search to objects of this package type. - @return The id of the first object found and an empty string if no object - is found. Throws an error if no node with given url can be found. + @return The id of the first object found and an empty string if no object + is found. Throws an error if no node with given url can be found. - @author Peter Marklund - } { - # Make sure we have the id of the start node to work with - if { [empty_string_p $node_id] } { - if { [empty_string_p $url] } { - set url "/" - } + @author Peter Marklund +} { + # Make sure we have the id of the start node to work with + if { [empty_string_p $node_id] } { + if { [empty_string_p $url] } { + set url "/" + } - set node_id [site_node::get_node_id -url $url] - } + set node_id [site_node::get_node_id -url $url] + } - # Climb up the site map starting with node_id and stop when we have - # an object to use as context or when we have reached the root node - set loop_node_id $node_id - set main_node_id [site_node::get_node_id -url "/"] - set context_id "" - set context_package_key "___${package_key}" - while { [empty_string_p $context_id] && \ - [expr [empty_string_p $package_key] || [string equal $package_key $context_package_key]]} { + # Climb up the site map starting with node_id and stop when we have + # an object to use as context or when we have reached the root node + set loop_node_id $node_id + set main_node_id [site_node::get_node_id -url "/"] + set context_id "" + set context_package_key "___${package_key}" + while { [empty_string_p $context_id] && \ + [expr [empty_string_p $package_key] || [string equal $package_key $context_package_key]]} { - set loop_node_id [site_node::get_parent_id -node_id $loop_node_id] - - if { [string equal $loop_node_id ""] } { - # There is no parent node - we reached the root of the site map - break - } - - array set node_array [site_node::get -node_id $loop_node_id] - set context_id $node_array(object_id) - set context_package_key $node_array(package_key) - } + set loop_node_id [site_node::get_parent_id -node_id $loop_node_id] + + if { [string equal $loop_node_id ""] } { + # There is no parent node - we reached the root of the site map + break + } + + array set node_array [site_node::get -node_id $loop_node_id] + set context_id $node_array(object_id) + set context_package_key $node_array(package_key) + } - return $context_id - } -} + return $context_id +} + ############## # # Deprecated Procedures