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
- the main site.
+ 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.
+ over any provided url.
@param package_key Restrict search to objects of this package type. You
- may supply a list of package_keys.
+ 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
- empty.
+ 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?
@@ -942,7 +1008,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
} {
@@ -1016,37 +1082,37 @@
# 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]]
+ # 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)
- }
- }
+ 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,7 +1153,10 @@
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]
@@ -1099,3 +1168,636 @@
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 {[catch {ns_cache flush xo_site_nodesNOTHING}]} {
+ ns_log notice "xotcl-core: 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} {
+ ns_cache_eval xo_site_nodes id-$url { next }
+ }
+
+ :protected method properties {-node_id:required} {
+ ns_cache_eval xo_site_nodes p-$node_id { next }
+ }
+
+ :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 {
+ foreach {url node_id object_id} $entry break
+ 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 {"2.0.0" in [package versions nsf]} {
+ 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.
+ site_node::update_cache -sync_children -node_id $node_id
+
+ # 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 command ::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 "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:
+