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"
}