include_self is set.
- @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
+ @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
+ @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. You
+ @param package_key Restrict search to objects of this package type. You
may supply a list of package_keys.
- @param include_self Return the package_id at the passed-in node if it is
- of the desired package_key. Ignored if package_key is
+ @param include_self Return the package_id at the passed-in node if it is
+ of the desired package_key. Ignored if package_key is
empty.
@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.
+ is found. Throws an error if no node with given url can be found.
@author Peter Marklund
} {
# Make sure we have a url to work with
if { $url eq "" } {
- if { $node_id eq "" } {
- set url "/"
- } else {
- set url [site_node::get_url -node_id $node_id]
- }
+ if { $node_id eq "" } {
+ set url "/"
+ } else {
+ set url [site_node::get_url -node_id $node_id]
+ }
}
# should we return the package at the passed-in node/url?
@@ -811,27 +921,28 @@
# move up a level
set url [string trimright $url /]
set url [string range $url 0 [string last / $url]]
-
+
array set node_array [site_node::get -url $url]
# are we looking for a specific package_key?
- if { $package_key eq "" || \
- [lsearch -exact $package_key $node_array(package_key)] != -1 } {
+ if { $package_key eq ""
+ || $node_array(package_key) in $package_key
+ } {
set elm_value $node_array($element)
- }
+ }
}
return $elm_value
-}
+}
ad_proc -public site_node::get_package_url {
{-package_key:required}
} {
Get the URL of any mounted instance of a package with the given package_key.
If there is more than one mounted instance of a package, returns
- the first URL. To see all of the mounted URLs, use the
+ the first URL. To see all of the mounted URLs, use the
site_node::get_children proc.
@return a URL, or empty string if no instance of the package is mounted.
@@ -857,7 +968,7 @@
Returns folder name to use, or empty string if the supplied folder name wasn't acceptable.
} {
set existing_urls [site_node::get_children -node_id $parent_node_id -element name]
-
+
array set parent_node [site_node::get -node_id $parent_node_id]
if { $parent_node(package_key) ne "" } {
# Find all the page or directory names under this package
@@ -873,10 +984,10 @@
lappend existing_urls $name
}
}
- }
+ }
if { $folder ne "" } {
- if { [lsearch $existing_urls $folder] != -1 } {
+ if { $folder in $existing_urls } {
# The folder is on the list
if { $current_node_id eq "" } {
# New node: Complain
@@ -885,8 +996,9 @@
# Renaming an existing node: Check to see if the node is merely conflicting with itself
set parent_url [site_node::get_url -node_id $parent_node_id]
set new_node_url "$parent_url$folder"
- if { ![site_node::exists_p -url $new_node_url] || \
- $current_node_id != [site_node::get_node_id -url $new_node_url] } {
+ if { ![site_node::exists_p -url $new_node_url]
+ || $current_node_id != [site_node::get_node_id -url $new_node_url]
+ } {
return {}
}
}
@@ -942,7 +1054,7 @@
@param sync_p If "t", we flush the in-memory site map
@param delete_p If "t", we attempt to delete the site node. This
- will fail if you have not cleaned up child nodes
+ will fail if you have not cleaned up child nodes
@param node_id The node_id to unmount
} {
@@ -975,10 +1087,10 @@
package_keys
} {
- Use site_node::closest_ancestor_package. Note that - site_node_closest_ancestor_package will include the passed-in node in the - search, whereas the new proc doesn't by default. If you want to include - the passed-in node, call site_node::closest_ancestor_package with the + Use site_node::closest_ancestor_package. Note that + site_node_closest_ancestor_package will include the passed-in node in the + search, whereas the new proc doesn't by default. If you want to include + the passed-in node, call site_node::closest_ancestor_package with the -include_self flag
@@ -1016,39 +1128,39 @@ # Try the URL as is. if {[catch {nsv_get site_nodes $url} result] == 0} { - array set node $result - if {$node(package_key) in $package_keys} { - return $node(package_id) - } + array set node $result + if {$node(package_key) in $package_keys} { + return $node(package_id) + } } - + # Add a trailing slash and try again. if {[string index $url end] ne "/"} { - append url "/" - if {[catch {nsv_get site_nodes $url} result] == 0} { - array set node $result - if {$node(package_key) in $package_keys} { - return $node(package_id) - } - } + append url "/" + if {[catch {nsv_get site_nodes $url} result] == 0} { + array set node $result + if {$node(package_key) in $package_keys} { + return $node(package_id) + } + } } - + # Try successively shorter prefixes. while {$url ne ""} { - # Chop off last component and try again. - set url [string trimright $url /] - set url [string range $url 0 [string last / $url]] - - if {[catch {nsv_get site_nodes $url} result] == 0} { - array set node $result - if {$node(pattern_p) == "t" - && $node(object_id) ne "" - && $node(package_key) in $package_keys} { - return $node(package_id) - } - } + # Chop off last component and try again. + set url [string trimright $url /] + set url [string range $url 0 [string last / $url]] + + if {[catch {nsv_get site_nodes $url} result] == 0} { + array set node $result + if {$node(pattern_p) == "t" + && $node(object_id) ne "" + && $node(package_key) in $package_keys} { + return $node(package_id) + } + } } - + return $default } @@ -1087,15 +1199,665 @@ ad_proc -public site_node::conn_url { } { - Use this in place of ns_conn url when referencing host_nodes. This proc returns the appropriate ns_conn url value, depending on if host_node_map is used for current connection, or hostname's domain. + Use this in place of ns_conn url when referencing host_nodes. + This proc returns the appropriate ns_conn url value, depending on + if host_node_map is used for current connection, or hostname's + domain. } { set ns_conn_url [ns_conn url] set subsite_get_url [subsite::get_url] set joined_url [file join $subsite_get_url $ns_conn_url] # join drops ending slash for some cases. Add back if appropriate. - if { [string range $ns_conn_url end end] eq "/" && [string range $joined_url end end] ne "/" } { + if { [string index $ns_conn_url end] eq "/" && [string index $joined_url end] ne "/" } { append joined_url "/" } return $joined_url } + +##################################################################### +# old end of file +##################################################################### + +if {$UseXotclSiteNodes} { + + # + # If we are in this branch of the "if" statement, we want to use the + # XOTcl-based infrastructure. + # + # First, we define a class for handling SiteNodes in the ::xo + # namespace (like other XOTcl based support functions). Afterwards + # we define some of the procs above to used this infrastructure. + # + + namespace eval ::xo { + + ##################################################### + # @class SiteNode + ##################################################### + # + # This class capsulates access to site-nodes stored in the + # database. It is written in a style to support the the needs + # of the Tcl-based API above. + # + # @author Gustaf Neumann + + ::nx::Class create SiteNode { + + # + # @method get + # returns a site node from url or site-node with all its context info + # + + :public method get { + {-url ""} + {-node_id ""} + } { + if {$url eq "" && $node_id eq ""} { + error "site_node::get \"must pass in either url or node_id\"" + } + + # + # make sure, we have a node_id + # + if {$node_id eq ""} { + set node_id [:get_node_id -url $url] + } + + return [:properties -node_id $node_id] + } + + # + # @method properties + # returns a site node from node_id with all its context info + # + + :protected method properties { + -node_id:integer,required + } { + # + # Get url, since it is not returned by the later query. + + # TODO: I did not want to modifiy the query for the time + # being. When doing the Oracle support, the retrieval of the URL + # should be moved into the query below.... + # + set url [:get_url -node_id $node_id] + + # + # get site-node with context from the database + # + ::db_1row dbqd.acs-tcl.tcl.site-nodes-procs.site_node::update_cache.select_site_node {} + + set object_type [expr {$package_id eq "" ? "" : "apm_package"}] + set list [list url $url node_id $node_id parent_id $parent_id name $name \ + directory_p $directory_p pattern_p $pattern_p object_id $object_id \ + object_type $object_type package_key $package_key package_id $package_id \ + instance_name $instance_name package_type $package_type] + return $list + } + + # + # @method get_children + # get children of a site node + # + + :public method get_children { + -node_id:required + -all:switch + {-package_type ""} + {-package_key ""} + {-filters ""} + {-element ""} + } { + # + # Fitering happens here exactly like in the nsv-based version. If should be possible to + # realize (at least some of the) filtering via the SQL query + # + if {$all} { + # + # the following query is just for PG, TODO: Oracle is missing + # + set child_urls [::xo::dc list [current method]-all { + select site_node__url(children.node_id) + from site_nodes as parent, site_nodes as children + where parent.node_id = :node_id + and children.tree_sortkey between parent.tree_sortkey and tree_right(parent.tree_sortkey) + and children.tree_sortkey <> parent.tree_sortkey + }] + } else { + if {$package_key ne ""} { + # + # Simple optimization for package_keys; seems to be frequenty used. + # We leave the logic below unmodified, which could be optimized as well. + # + set package_key_clause "and package_id = object_id and package_key = :package_key" + set from "site_nodes, apm_packages" + } else { + set package_key_clause "" + set from "site_nodes" + } + set sql [::xo::dc select \ + -vars site_node__url(node_id) \ + -from $from \ + -where "parent_id = :node_id $package_key_clause" \ + -map_function_names true] + set child_urls [::xo::dc list [current method] $sql] + } + + if { $package_type ne "" } { + lappend filters package_type $package_type + } elseif { $package_key ne "" } { + lappend filters package_key $package_key + } + + if { [llength $filters] > 0 } { + set return_val [list] + foreach child_url $child_urls { + array unset site_node + if {![catch {array set site_node [:get -url $child_url]}]} { + + set passed_p 1 + foreach { elm val } $filters { + if { $site_node($elm) ne $val } { + set passed_p 0 + break + } + } + if { $passed_p } { + if { $element ne "" } { + lappend return_val $site_node($element) + } else { + lappend return_val $child_url + } + } + } + } + } elseif { $element ne "" } { + set return_val [list] + foreach child_url $child_urls { + array unset site_node + if {![catch {array set site_node [:get -url $child_url]}]} { + lappend return_val $site_node($element) + } + } + } else { + set return_val $child_urls + } + + return $return_val + } + + + # + # @method get_urls_from_object_id + # + # returns a list of urls for site_nodes that have the given + # object mounted or the empty list if there are none. The urls + # 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. + # + + :public method get_urls_from_object_id { + -object_id:required + } { + # + # the following query is just for PG, TODO: Oracle is missing + # + set child_urls [::xo::dc list [current method]-all { + select site_node__url(node_id) + from site_nodes + where object_id = :object_id + order by tree_sortkey desc + }] + } + + :public method get_urls_from_package_key { + -package_key:required + } { + return [::xo::dc list [current method]-urls-from-package-key { + select site_node__url(node_id) + from site_nodes n, apm_packages p + where p.package_key = :package_key + and n.object_id = p.package_id + }] + } + + # + # @method get_node_id get_package_url + # just a small stub for a special case for method + # get_urls_from_package_key + # + :public method get_package_url { + -package_key:required + } { + return [lindex [:get_urls_from_package_key -package_key $package_key] 0] + } + + # + # @method get_node_id + # obtain node id from url, using directly the stored procedure + # site_node.node_id + # + # ::xo::db::sql::site_node node_id -url url ?-parent_id parent_id? + # + :public forward get_node_id ::xo::db::sql::site_node node_id + + # + # @method get_url + # obtain url from node-id, using directly the stored procedure + # site_node.url + # + # ::xo::db::sql::site_node url -node_id node_id + # + :public forward get_url ::xo::db::sql::site_node url + + # + # @method flush_cache + # a stub to be overloaded by the cache manager + # + :public method flush_cache {{-node_id ""} {-with_subtree:boolean}} {;} + + # Create an object "site_node" to provide a user-interface close + # to the classical one. + :create site_node + } + + ##################################################### + # Caching + ##################################################### + + if {[info commands ::ns_cache_names] ne ""} { + set createCache [expr {"xo_site_nodes" ni [::ns_cache_names]}] + } else { + set createCache [catch {ns_cache flush xo_site_nodes NOTHING}] + } + if {$createCache} { + ns_log notice "creating xo_site_nodes cache" + ns_cache create xo_site_nodes -size 2000000 + } + + # + # SiteNodeCache is a mixin class for caching the SiteNode objects. + # Add/remove caching methods as wanted. Removing the registry of + # the object mixin deactivates caching for these methods + # completely. + # + + ::nx::Class create SiteNodeCache { + + :public method get_children { + -node_id:required + {-all:switch} {-package_type ""} {-package_key ""} {-filters ""} {-element ""} + } { + ns_cache_eval xo_site_nodes get_children-$node_id-$all-$package_type-$package_key-$filters-$element { next } + } + + :public method get_node_id {-url:required} { + return [ns_cache_eval xo_site_nodes id-$url { next }] + } + + :protected method properties {-node_id:required} { + set key ::xo_site_nodes_property($node_id) + if {[info exists $key]} { + return [set $key] + } + set $key [ns_cache_eval xo_site_nodes p-$node_id { next }] + return [set $key] + } + + :public method get_url {-node_id:required} { + ns_cache_eval xo_site_nodes url-$node_id { next } + } + + :public method get_urls_from_object_id {-object_id:required} { + ns_cache_eval xo_site_nodes urls-$object_id { next } + } + + # The cache value from the following method is currently not + # flushed, but just used for package keys, not instances, so it + # should be safe. + :public method get_package_url {-package_key:required} { + ns_cache_eval xo_site_nodes package_url-$package_key { next } + } + + :protected method flush_all {patterns} { + foreach pattern $patterns { + foreach key [ns_cache names xo_site_nodes $pattern] { + #:msg ......key=$key + ::xo::clusterwide ns_cache flush xo_site_nodes $key + } + } + } + + :public method flush_cache {{-node_id ""} {-with_subtree:boolean true}} { + # + # Flush entries from site-node tree, including the current node, + # the root of flushed (sub)tree. If the node_id is not provided, + # or it is the node_id of root of the full site-node tree, flush + # the whole tree. + # + + set old_url [:get_url -node_id $node_id] + + if {$node_id eq "" || $old_url eq "/"} { + foreach i [ns_cache names xo_site_nodes] { + ::xo::clusterwide ns_cache flush xo_site_nodes $i + } + } else { + set limit_clause [expr {$with_subtree ? "" : "limit 1"}] + # + # the following query is just for PG, TODO: Oracle is missing + # + set tree [::xo::dc list_of_lists [current method]-flush-tree " + select site_node__url(children.node_id), children.node_id, children.object_id + from site_nodes as parent, site_nodes as children + where parent.node_id = :node_id + and children.tree_sortkey between parent.tree_sortkey and tree_right(parent.tree_sortkey) + $limit_clause + "] + foreach entry $tree { + lassign $entry url node_id object_id + foreach key [list p-$node_id url-$node_id urls-$object_id] { + ::xo::clusterwide ns_cache flush xo_site_nodes $key + } + :flush_all get_children-$node_id-* + } + regsub {/$} $old_url "" old_url + :flush_all id-$old_url* + } + } + + } + + # Turn on caching by registering the mixin (backward compatibility + # for early XOTcl2-versions, probably not needed anymore). + if {[package require nsf] >= "2.0.0"} { + site_node object mixins add SiteNodeCache + } else { + site_node object mixin add SiteNodeCache + } + } + + ##################################################################### + # Begin of overwritten procs from above + ##################################################################### + # + # The site-node implementation above depends on the nsv-array + # "site_nodes". We have to overwrite this API to avoid these calls + # and/or to use the XOTcl-based infrastructure. + + ad_proc -public site_node::new { + {-name:required} + {-parent_id:required} + {-directory_p t} + {-pattern_p t} + } { + create a new site node + } { + set var_list [list \ + [list name $name] \ + [list parent_id $parent_id] \ + [list directory_p $directory_p] \ + [list pattern_p $pattern_p]] + + set node_id [package_instantiate_object -var_list $var_list site_node] + return $node_id + } + + ad_proc -public site_node::mount { + {-node_id:required} + {-object_id:required} + {-context_id} + } { + mount object at site node + } { + db_dml mount_object {} + db_dml update_object_package_id {} + + # We might have for this node_id (or under it) some entries in + # the cache, so flush these first. Since the cache might + # contain children, we have to flush on all ancestor nodes up + # to the top node. + set ancestors [site_node::get_ancestors -node_id $node_id -element node_id] + foreach n $ancestors { + site_node::update_cache -sync_children -node_id $n + } + + # DAVEB update context_id if it is passed in + # some code relies on context_id to be set by + # instantiate_and_mount so we can't assume + # anything at this point. Callers that need to set context_id + # for example, when an unmounted package is mounted, + # should pass in the correct context_id + if {[info exists context_id]} { + db_dml update_package_context_id "" + } + + set package_key [apm_package_key_from_id $object_id] + foreach inherited_package_key [nsv_get apm_package_inherit_order $package_key] { + apm_invoke_callback_proc \ + -package_key $inherited_package_key \ + -type after-mount \ + -arg_list [list package_id $object_id node_id $node_id] + } + } + + ad_proc -private site_node::init_cache {} { + Initialize the site node cache; actually, this means flushing the + cache in case we have root site node. + } { + ns_log notice "site_node::init_cache" + set root_node_id [::db_string get_root_node_id {} -default {}] + if { $root_node_id ne "" } { + # If we are called during the *-init procs, the database + # interface might not be initialized yet. However, in this + # situation, there is nothing to flush yet. + if {[info commands ::xo::db::sql::site_node] ne ""} { + ::xo::site_node flush_cache -node_id $root_node_id + } + } + } + + ad_proc -private site_node::update_cache { + {-sync_children:boolean} + {-node_id:required} + } { + Brings the in memory copy of the site nodes hierarchy in sync with the + database version. Only updates the given node and its children. + } { + #ns_log Notice "site_node::update_cache for node_id $node_id" + ::xo::site_node flush_cache -node_id $node_id -with_subtree $sync_children_p + } + + ad_proc -public site_node::get { + {-url ""} + {-node_id ""} + } { + Returns an array representing the site node that matches the given 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. + } { + return [::xo::site_node get -url $url -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.+ + 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 + } { + # TODO: The switch "-exact" does nothing here... Needed? + return [::xo::site_node get -node_id [::xo::site_node get_node_id -url $url]] + } + + ad_proc -public site_node::exists_p { + {-url:required} + } { + Returns 1 if a site node exists at the given url and 0 otherwise. + } { + + set url_no_trailing [string trimright $url "/"] + + # get_node_id returns always a node_id, which might be the node_id + # of the root. In order to check, whether the provided url is + # really a site-node, we do an inverse lookup and check whether + # the returned node_id has the same url as the provided one. + # + set node_id [::xo::site_node get_node_id -url $url_no_trailing] + return [expr {[::xo::site_node get_url -node_id $node_id] eq "$url_no_trailing/"}] + } + + ad_proc -public site_node::get_url { + {-node_id:required} + {-notrailing:boolean} + } { + return the url of this node_id + + @notrailing If true then strip any + trailing slash ('/'). This means the empty string is returned for the root. + } { + set url [::xo::site_node get_url -node_id $node_id] + if { $notrailing_p } { + set url [string trimright $url "/"] + } + return $url + } + + 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. + } { + ::xo::site_node get_urls_from_object_id -object_id $object_id + } + + ad_proc -public site_node::get_children { + {-all:boolean} + {-package_type {}} + {-package_key {}} + {-filters {}} + {-element {}} + {-node_id:required} + } { + This proc gives answers to questions such as: What are all the package_id's + (or any of the other available elements) for all the instances of package_key or package_type mounted + under node_id xxx? + + @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. Conflicts with the -package_key option. + + @param package_key If specified, this will limit the returned nodes to those with a + package of the specified package key mounted. Conflicts with the + -package_type option. Can take one or more packges keys as a Tcl list. + + @param filters Takes a list of { element value element value ... } for filtering + the result list. Only nodes where element is value for each of the + filters in the list will get included. For example: + -filters { package_key "acs-subsite" }. + + @param element The element of the site node you wish returned. Defaults to url, but + the following elements are available: object_type, url, object_id, + instance_name, package_type, package_id, name, node_id, directory_p. + + @return A list of URLs of the site_nodes immediately under this site node, or all children, + if the -all switch is specified. + } { + ::xo::site_node get_children -all=$all_p -package_type $package_type -package_key $package_key \ + -filters $filters -element $element -node_id $node_id + } + + ad_proc -public site_node::get_package_url { + {-package_key:required} + } { + Get the URL of any mounted instance of a package with the given package_key. + + If there is more than one mounted instance of a package, returns + the first URL. To see all of the mounted URLs, use the + site_node::get_children proc. + + @return a URL, or empty string if no instance of the package is mounted. + @see site_node::get_children + } { + return [::xo::site_node get_package_url -package_key $package_key] + } + + ad_proc -deprecated -warn site_node_closest_ancestor_package { + { -default "" } + { -url "" } + package_keys + } { +
+ Use site_node::closest_ancestor_package. Note that + site_node_closest_ancestor_package will include the passed-in node in the + search, whereas the new proc doesn't by default. If you want to include + the passed-in node, call site_node::closest_ancestor_package with the + -include_self flag +
+ ++ Finds the package id of a package of specified type that is + closest to the node id represented by url (or by ad_conn url).Note + that closest means the nearest ancestor node of the specified + type, or the current node if it is of the correct type. + +
+ + Usage: + +
+ # Pull out the package_id of the subsite closest to our current node + set pkg_id [site_node::closest_ancestor_package -include_self -package_key "acs-subsite"] ++ + @param default The value to return if no package can be found + @param current_node_id The node from which to start the search + @param package_keys The type(s) of the package(s) for which we are looking + + @return
package_id of the nearest package of the
+ specified type (package_key). Returns $default if no
+ such package can be found.
+
+ @see site_node::closest_ancestor_package
+ } {
+
+ if {$url eq ""} {
+ set url [ad_conn url]
+ }
+
+ set result [site_node::closest_ancestor_package -package_key $package_keys -url $url -include_self]
+ if {$result eq ""} {
+ set result $default
+ }
+ return $result
+ }
+ #
+ # End of overwritten procs.
+ #
+}
+
+#
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End: