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.92 -r1.93
--- openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl 15 Jun 2015 13:03:32 -0000 1.92
+++ openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl 15 Jun 2015 13:13:41 -0000 1.93
@@ -9,66 +9,6 @@
}
-#####################################################################
-#
-# One has the option to use either the classical site-nodes code based
-# on nsvs or the new XOTcl based code. The classical code has the
-# disadvantage that it takes a while on start-up, uses a lot of
-# memory, and is non-scalable on size and parallelization. The new
-# xotcl-based version is much faster from a factor of two to a several
-# thousand times - but requires XOTcl, which has not made it yet to the
-# acs-core procs.
-#
-# Some timings:
-# simple installation:
-# nsv-based get_children: 291 microseconds
-# xotcl-based get_children: 30 microseconds
-#
-# implementation with 130.000 site-nodes
-# nsv-based get_children: 1535380 microseconds
-# xotcl-based get_children: 186 microseconds
-#
-# array set n [nsv_get site_nodes /]
-# ds_comment [time {site_node::get_children -node_id $n(node_id)}]
-# ds_comment [time {::xo::site_node get_children -node_id $n(node_id)}]
-#
-# The easiest and most straightforward implementation is to put the
-# few XOTcl classes here into this file (what i did for now), since it
-# makes it easier to handle reloads, etc.
-#
-# If the variable UseXotclSiteNodes is set, we define a few of the
-# ad_procs below to use the XOTcl-based infrastructure.
-#
-# In case, you are using dotlrn, make sure to use an up-to-date
-# version of dotlrn that does not bypass the API to access the nsv
-# "site_nodes". Make sure to use as well the two fixes by Victor
-# Guerra for applets-procs.tcl and dotlrn-procs.tcl from May 12 2010.
-#
-# -gustaf neumann (May 2010)
-#
-# NX-based version (Feb 2011)
-# For non-naviserver one has to s/ns_cache_eval/ns_cache eval/g
-#
-#####################################################################
-#
-
-set UseXotclSiteNodes 1
-
-
-#
-# Saftey belt: The XOTcl classes below depend on xotcl-core (in
-# particular 05-db-procs.tcl), so if these are not available there
-# would be a problem. The current implementation does not support
-# oracle. So, never allow a configuration of UseXotclSiteNodes if it
-# can't work.
-#
-if {[info command ::xotcl::Object] eq ""
- || ![file exists [acs_root_dir]/packages/xotcl-core/tcl/05-db-procs.tcl]
- || [db_driverkey ""] eq "oracle"
- } {
- set UseXotclSiteNodes 0
-}
-
#----------------------------------------------------------------------
# site_nodes data structure
#----------------------------------------------------------------------
@@ -81,6 +21,7 @@
# no ordering
# nsv site_nodes_mutex = mutex object used to control concurrency
+
namespace eval site_node {}
ad_proc -public site_node::new {
@@ -331,7 +272,7 @@
nsv_array reset site_node_url_by_object_id [list]
nsv_array reset site_node_url_by_package_key [list]
- set root_node_id [::db_string get_root_node_id {} -default {}]
+ set root_node_id [db_string get_root_node_id {} -default {}]
if { $root_node_id ne "" } {
site_node::update_cache -sync_children -node_id $root_node_id
}
@@ -847,7 +788,6 @@
@author Peter Marklund
} {
-
# Make sure we have a url to work with
if { $url eq "" } {
if { $node_id eq "" } {
@@ -866,7 +806,7 @@
}
}
- set elm_value ""
+ set elm_value {}
while { $elm_value eq "" && $url ne "/"} {
# move up a level
set url [string trimright $url /]
@@ -878,12 +818,13 @@
if { $package_key eq "" || \
[lsearch -exact $package_key $node_array(package_key)] != -1 } {
set elm_value $node_array($element)
- }
+ }
}
return $elm_value
-}
+}
+
ad_proc -public site_node::get_package_url {
{-package_key:required}
} {
@@ -1148,658 +1089,13 @@
} {
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]
- # get config.tcl's hostname
- set nssock [ns_config ns/server/[ns_info server]/modules nssock]
- set nsunix [ns_config ns/server/[ns_info server]/modules nsunix]
- if {$nsunix ne ""} {
- set driver nsunix
- } else {
- set driver nssock
+ 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 "/" } {
+ append joined_url "/"
}
- set config_hostname [ns_config ns/server/[ns_info server]/module/$driver Hostname]
- set current_location [util_current_location]
- # if current domain and hostdomain are different (and UseHostnameDomain), revise ns_conn_url
- if { ![string match -nocase "*${config_hostname}*" $current_location] } {
- # revise return_url to use hostname's domain
- set host_node_map_hosts_list [db_list -cache_key security-locations-host-names get_node_host_names "select host from host_node_map"]
- if { [llength $host_node_map_hosts_list] > 0 } {
- foreach hostname $host_node_map_hosts_list {
- if { [string match -nocase "http://${hostname}*" $current_location] || [string match -nocase "https://${hostname}*" $current_location] } {
- ::db_1row get_node_id_from_host_name "select node_id as host_node_id from host_node_map where host = :hostname"
-
- if { ![regsub -- "[site_node::get_url -node_id ${host_node_id} -notrailing]" $ns_conn_url {} ns_conn_url] } {
- ns_log Warning "site_node:conn_url(ref1111): regsub was unable to modify conn_url. User may not have reached intended url. ns_conn_url: ${ns_conn_url} ns_conn url: [ns_conn 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 {[catch {ns_cache flush xo_site_nodes NOTHING}]} {
- ns_log notice "xotcl-core: creating xo_site_nodes cache"
- ns_cache create xo_site_nodes -size 6000000
- }
-
- #
- # 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 [:qn [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
- site_node object mixins 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.
- } {
- 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.
- } {
- ::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.
- } {
- #
- # With Tcl 8.5 we would need no "if" statement here...
- #
- if {$all_p} {
- ::xo::site_node get_children -all -package_type $package_type -package_key $package_key \
- -filters $filters -element $element -node_id $node_id
- } else {
- ::xo::site_node get_children -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.
- #
-}