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.91 -r1.92 --- openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl 27 Oct 2014 16:40:08 -0000 1.91 +++ openacs-4/packages/acs-tcl/tcl/site-nodes-procs.tcl 15 Jun 2015 13:03:32 -0000 1.92 @@ -9,6 +9,66 @@ } +##################################################################### +# +# 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 #---------------------------------------------------------------------- @@ -21,7 +81,6 @@ # no ordering # nsv site_nodes_mutex = mutex object used to control concurrency - namespace eval site_node {} ad_proc -public site_node::new { @@ -272,7 +331,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 } @@ -788,6 +847,7 @@ @author Peter Marklund } { + # Make sure we have a url to work with if { $url eq "" } { if { $node_id eq "" } { @@ -806,7 +866,7 @@ } } - set elm_value {} + set elm_value "" while { $elm_value eq "" && $url ne "/"} { # move up a level set url [string trimright $url /] @@ -818,13 +878,12 @@ 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} } { @@ -1089,12 +1148,658 @@ } { 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 "/" } { - append joined_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 } - return $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]" + } + } + } + } + } } + +##################################################################### +# 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. + # +} Index: openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl,v diff -u -r1.137 -r1.138 --- openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 12 Jun 2015 21:04:57 -0000 1.137 +++ openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 15 Jun 2015 13:03:32 -0000 1.138 @@ -2090,7 +2090,7 @@ append cookie "; Secure" } - if { $scriptable == "t" } { + if { $scriptable == "f" } { # Prevent access to this cookie via JavaScript append cookie "; HttpOnly" }