the value "no_sort" should be used for columns which should not allow sorting. -
- the value "sort_by_pos" should be used if the columns passed in - are column positions rather than column names. +
+ the value "sort_by_pos" should be used if the columns passed in + are column positions rather than column names.
| [lindex $Tcol 1] | \n" - } else { - if {[lindex $Tcol 0] eq $Torderbykey } { - if {$Torder eq "desc"} { - set Tasord $Tasc_order_img - } else { - set Tasord $Tdesc_order_img - } - } else { - set Tasord {} - } - set href $Tsort_url[ns_urlencode [ad_new_sort_by [lindex $Tcol 0] $Torderby]] - append Theader \ - [subst {}] \ - "\n[lindex $Tcol 1] $Tasord | \n" - } - } - append Theader "[lindex $Tcol 1] | \n" + } else { + if {[lindex $Tcol 0] eq $Torderbykey } { + if {$Torder eq "desc"} { + set Tasord $Tasc_order_img + } else { + set Tasord $Tdesc_order_img + } + } else { + set Tasord {} + } + set href $Tsort_url[ns_urlencode [ad_new_sort_by [lindex $Tcol 0] $Torderby]] + append Theader \ + [subst {}] \ + "\n[lindex $Tcol 1] $Tasord | \n" + } + } + append Theader "\n" - # - # This has gotten kind of ugly. Here we are looping over the - # rows returned and then potentially a list of ns_sets which can - # be passed in (grrr. Richard Li needs for general protections stuff - # for "fake" public record which does not exist in DB). - # + # + # This has gotten kind of ugly. Here we are looping over the + # rows returned and then potentially a list of ns_sets which can + # be passed in (grrr. Richard Li needs for general protections stuff + # for "fake" public record which does not exist in DB). + # - set Tpost_data 0 + set Tpost_data 0 - while { 1 } { - if {!$Tpost_data && [ns_db getrow $Tdb $selection]} { - # in all its evil majesty - set_variables_after_query - } else { - # move on to fake rows... - incr Tpost_data - } + while { 1 } { + if {!$Tpost_data && [ns_db getrow $Tdb $selection]} { + # in all its evil majesty + set_variables_after_query + } else { + # move on to fake rows... + incr Tpost_data + } - if { $Tpost_data && $Tpost_data <= [llength $Tpost_data_ns_sets] } { - # bind the Tpost_data_ns_sets row of the passed in data - set_variables_after_query_not_selection [lindex $Tpost_data_ns_sets $Tpost_data-1] - } elseif { $Tpost_data } { - # past the end of the fake data drop out. - break - } + if { $Tpost_data && $Tpost_data <= [llength $Tpost_data_ns_sets] } { + # bind the Tpost_data_ns_sets row of the passed in data + set_variables_after_query_not_selection [lindex $Tpost_data_ns_sets $Tpost_data-1] + } elseif { $Tpost_data } { + # past the end of the fake data drop out. + break + } - if { $Tmax_rows && $Tcount >= $Tmax_rows } { - if { ! $Tpost_data } { - # we hit max count and had rows left to read... - ns_db flush $Tdb - } - break - } + if { $Tmax_rows && $Tcount >= $Tmax_rows } { + if { ! $Tpost_data } { + # we hit max count and had rows left to read... + ns_db flush $Tdb + } + break + } - # deal with putting in the header if need - if { $Tcount == 0 } { - append Thtml "$Theader" - } elseif { $Tpage_count == 0 } { - append Thtml "
|---|
Tests whether or not $v is a member of set $s.
} { if {$v ni $s} { - return 0 + return 0 } else { - return 1 + return 1 } } @@ -2126,7 +2126,7 @@ upvar $s-name s if { ![set_member? $s $v] } { - lappend s $v + lappend s $v } } @@ -2138,9 +2138,9 @@ set result $u foreach ve $v { - if { ![set_member? $result $ve] } { - lappend result $ve - } + if { ![set_member? $result $ve] } { + lappend result $ve + } } return $result @@ -2155,9 +2155,9 @@ upvar $u-name u foreach ve $v { - if { ![set_member? $u $ve] } { - lappend u $ve - } + if { ![set_member? $u $ve] } { + lappend u $ve + } } return $u @@ -2172,9 +2172,9 @@ set result [list] foreach ue $u { - if { [set_member? $v $ue] } { - lappend result $ue - } + if { [set_member? $v $ue] } { + lappend result $ue + } } return $result @@ -2190,9 +2190,9 @@ set result [list] foreach ue $u { - if { [set_member? $v $ue] } { - lappend result $ue - } + if { [set_member? $v $ue] } { + lappend result $ue + } } set u $result @@ -2206,9 +2206,9 @@ set result [list] foreach ue $u { - if { ![set_member? $v $ue] } { - lappend result $ue - } + if { ![set_member? $v $ue] } { + lappend result $ue + } } return $result @@ -2224,9 +2224,9 @@ set result [list] foreach ue $u { - if { ![set_member? $v $ue] } { - lappend result $ue - } + if { ![set_member? $v $ue] } { + lappend result $ue + } } set u $result @@ -2871,19 +2871,19 @@ @see auth::create_local_account } { return [auth::create_local_account_helper \ - $email \ - $first_names \ - $last_name \ - $password \ - $password_question \ - $password_answer \ - $url \ - $email_verified_p \ - $member_state \ - $user_id \ - $username \ - $authority_id \ - $screen_name] + $email \ + $first_names \ + $last_name \ + $password \ + $password_question \ + $password_answer \ + $url \ + $email_verified_p \ + $member_state \ + $user_id \ + $username \ + $authority_id \ + $screen_name] } # @@ -2899,7 +2899,7 @@ {-array:required} } { Load up user information - @see acs_user::get + @see acs_user::get } { # Upvar the Tcl Array upvar $array row @@ -3006,12 +3006,12 @@ @see packages/acs-tcl/tcl/00-database-procs.tcl } { uplevel { - set set_variables_after_query_i 0 - set set_variables_after_query_limit [ns_set size $selection] - while {$set_variables_after_query_i<$set_variables_after_query_limit} { - set [ns_set key $selection $set_variables_after_query_i] [ns_set value $selection $set_variables_after_query_i] - incr set_variables_after_query_i - } + set set_variables_after_query_i 0 + set set_variables_after_query_limit [ns_set size $selection] + while {$set_variables_after_query_i<$set_variables_after_query_limit} { + set [ns_set key $selection $set_variables_after_query_i] [ns_set value $selection $set_variables_after_query_i] + incr set_variables_after_query_i + } } } @@ -3024,12 +3024,12 @@ @see packages/acs-tcl/tcl/00-database-procs.tcl } { uplevel { - set set_variables_after_query_i 0 - set set_variables_after_query_limit [ns_set size $sub_selection] - while {$set_variables_after_query_i<$set_variables_after_query_limit} { - set [ns_set key $sub_selection $set_variables_after_query_i] [ns_set value $sub_selection $set_variables_after_query_i] - incr set_variables_after_query_i - } + set set_variables_after_query_i 0 + set set_variables_after_query_limit [ns_set size $sub_selection] + while {$set_variables_after_query_i<$set_variables_after_query_limit} { + set [ns_set key $sub_selection $set_variables_after_query_i] [ns_set value $sub_selection $set_variables_after_query_i] + incr set_variables_after_query_i + } } } @@ -3047,10 +3047,10 @@ set set_variables_after_query_limit [ns_set size $selection_variable] while {$set_variables_after_query_i<$set_variables_after_query_limit} { # NB backslash squarebracket needed since mismatched {} would otherwise mess up value stmt. - uplevel " - set ${name_prefix}[ns_set key $selection_variable $set_variables_after_query_i] \[ns_set value $selection_variable $set_variables_after_query_i] - " - incr set_variables_after_query_i + uplevel " + set ${name_prefix}[ns_set key $selection_variable $set_variables_after_query_i] \[ns_set value $selection_variable $set_variables_after_query_i] + " + incr set_variables_after_query_i } } @@ -3098,11 +3098,11 @@ } { set session_user_id [ad_conn user_id] if {$session_user_id == 0} { - # viewer of this page isn't logged in, only show stuff - # that is extremely unprivate - set privacy_threshold 0 + # viewer of this page isn't logged in, only show stuff + # that is extremely unprivate + set privacy_threshold 0 } else { - set privacy_threshold 5 + set privacy_threshold 5 } return $privacy_threshold } @@ -4077,9 +4077,181 @@ return $keys } +######################################################################## +# deprecated site-nodes-procs.tcl +######################################################################## +namespace eval ::site_node {} +ad_proc -deprecated site_node_delete_package_instance { + {-node_id:required} +} { + Wrapper for apm_package_instance_delete + + @author Arjun Sanyal (arjun@openforc.net) + @creation-date 2002-05-02 + @see site_node::delete +} { + db_transaction { + set package_id [site_node::get_object_id -node_id $node_id] + site_node::unmount -node_id $node_id + apm_package_instance_delete $package_id + } on_error { + site_node::update_cache -node_id $node_id + } +} + +ad_proc -deprecated site_map_unmount_application { + { -sync_p "t" } + { -delete_p "f" } + node_id +} { + Unmounts the specified node. + + @author Michael Bryzek (mbryzek@arsdigita.com) + @creation-date 2001-02-07 + + @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 + @param node_id The node_id to unmount + @see site_node::unmount + +} { + db_transaction { + site_node::unmount -node_id $node_id + + if {$delete_p == "t"} { + site_node::delete -node_id $node_id + } + } +} + +ad_proc -deprecated site_node_id {url} { + Returns the node_id of a site node. Throws an error if there is no + matching node. + @see site_node::get_node_id +} { + return [site_node::get_node_id -url $url] +} + +ad_proc -deprecated site_nodes_sync {args} { + Brings the in-memory copy of the url hierarchy in sync with the + database version. + + @see site_node::init_cache +} { + site_node::init_cache +} + +ad_proc -deprecated -warn site_node_closest_ancestor_package { + { -default "" } + { -url "" } + package_keys +} { ++ Use site_node::closest_ancestor_package. Note that + site_node_closest_ancestor_package will include the passed-in node in the + search, whereas the new proc doesn't by default. If you want to include + the passed-in node, call site_node::closest_ancestor_package with the + -include_self flag +
+ ++ Finds the package id of a package of specified type that is + closest to the node id represented by url (or by ad_conn url).Note + that closest means the nearest ancestor node of the specified + type, or the current node if it is of the correct type. + +
+ + Usage: + +
+ # Pull out the package_id of the subsite closest to our current node + set pkg_id [site_node::closest_ancestor_package -include_self -package_key "acs-subsite"] ++ + @param default The value to return if no package can be found + @param url The url of 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
+}
+
+ad_proc -deprecated site_node_closest_ancestor_package_url {
+ { -default "" }
+ { -package_key {} }
+} {
+ Returns the url stub of the nearest application of the specified
+ type.
+
+ @author Michael Bryzek (mbryzek@arsdigita.com)
+ @creation-date 2001-02-05
+
+ @param package_key The types of packages for which we're looking (defaults to subsite packages)
+ @param default The default value to return if no package of the
+ specified type was found
+
+ @see site::node::closest_ancestor_package
+} {
+ if {$package_key eq ""} {
+ set package_key [subsite::package_keys]
+ }
+
+ set subsite_pkg_id [site_node::closest_ancestor_package \
+ -include_self \
+ -package_key $package_key \
+ -url [ad_conn url] ]
+
+ if {$subsite_pkg_id eq ""} {
+ # No package was found... return the default
+ return $default
+ }
+
+ return [lindex [site_node::get_url_from_object_id -object_id $subsite_pkg_id] 0]
+}
+
+ad_proc -deprecated 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.
+ @see ad_conn
+} {
+ set ns_conn_url [ns_conn url]
+ set subsite_get_url [subsite::get_url]
+ set joined_url [ad_file join $subsite_get_url $ns_conn_url]
+ # join drops ending slash for some cases. Add back if appropriate.
+ if { [string index $ns_conn_url end] eq "/" && [string index $joined_url end] ne "/" } {
+ append joined_url "/"
+ }
+ return $joined_url
+}
+
+########################################################################
+# Functions based on undefined code
+########################################################################
#
-# The following proc is based on undefined function
+# The following proc is based on undefined function
#
#
# -------------------------------------------------------
Index: openacs-4/packages/acs-tcl/tcl/site-nodes-procs-oracle.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/site-nodes-procs-oracle.xql,v
diff -u -r1.21 -r1.21.2.1
--- openacs-4/packages/acs-tcl/tcl/site-nodes-procs-oracle.xql 7 Aug 2017 23:48:00 -0000 1.21
+++ openacs-4/packages/acs-tcl/tcl/site-nodes-procs-oracle.xql 21 Feb 2022 20:35:11 -0000 1.21.2.1
@@ -3,12 +3,6 @@
- - 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 -} { - # attempt an exact match - if {[nsv_exists site_nodes $url]} { - return [nsv_get site_nodes $url] - } - - # attempt adding a / to the end of the url if it doesn't already have - # one - if {[string index $url end] ne "/" } { - append url "/" - if {[nsv_exists site_nodes $url]} { - return [nsv_get site_nodes $url] - } - } - - # chomp off part of the url and re-attempt - if {!$exact_p} { - while {$url ne ""} { - set url [string trimright $url /] - set url [string range $url 0 [string last / $url]] - - if {[nsv_exists site_nodes $url]} { - array set node [nsv_get site_nodes $url] - - if {$node(pattern_p) == "t" && $node(object_id) ne ""} { - return [array get node] - } - } - } - } - - error "site node not found at 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. - The provided URL has to start with a slash. - - @param url URL path starting with a slash. - @author Peter Marklund -} { - - ns_log notice "OLD nsv-based site_node::exists_p <$url>" - - - set url_no_trailing [string trimright $url "/"] - return [nsv_exists site_nodes "$url_no_trailing/"] -} - ad_proc -public site_node::get_from_object_id { {-object_id:required} } { @@ -672,43 +281,6 @@ return $node_id_list } -ad_proc -public site_node::get_url { - {-node_id:required} - {-notrailing:boolean} -} { - return the url of this node_id - - @param notrailing If true then strip any - trailing slash ('/'). This means the empty string is returned for the root. -} { - set url "" - if {[nsv_exists site_node_url_by_node_id $node_id]} { - set url [nsv_get site_node_url_by_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} -} { - Return 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. -} { - if { [nsv_exists site_node_url_by_object_id $object_id] } { - return [nsv_get site_node_url_by_object_id $object_id] - } else { - return [list] - } -} - ad_proc -public site_node::get_node_id { {-url:required} } { @@ -786,120 +358,6 @@ return [dict get [get -node_id $node_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 a 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 packages 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. - - @author Lars Pind (lars@collaboraid.biz) -} { - if { $package_type ne "" && $package_key ne "" } { - error "You may specify either package_type, package_key, or filter_element, but not more than one." - } - - if { $package_type ne "" } { - lappend filters package_type $package_type - } elseif { $package_key ne "" } { - lappend filters package_key $package_key - } - - set node_url [site_node::get_url -node_id $node_id] - - if { !$all_p } { - set child_urls [list] - set s [string length "$node_url"] - # find all child_urls who have only one path element below node_id - # by clipping the node url and last character and seeing if there - # is a / in the string. about 2x faster than the RE version. - foreach child_url [nsv_array names site_nodes "${node_url}?*"] { - if { [string first / [string range $child_url $s end-1]] < 0 } { - lappend child_urls $child_url - } - } - } else { - set child_urls [nsv_array names site_nodes "${node_url}?*"] - } - - - if { [llength $filters] > 0 } { - set return_val [list] - foreach child_url $child_urls { - array unset site_node - if {![catch {array set site_node [nsv_get site_nodes $child_url]}]} { - - set passed_p 1 - foreach { elm val } $filters { - # package_key supports one or more package keys - # since we can filter on the site node pretty name - # we can't just treat all filter values as a list - if {$elm eq "package_key" && [llength $val] > 1 && [lsearch $val $site_node($elm)] < 0} { - set passed_p 0 - break - } elseif {($elm ne "package_key" || [llength $val] == 1) && $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 [nsv_get site_nodes $child_url]}]} { - lappend return_val $site_node($element) - } - } - } - - # if we had filters or were getting a particular element then we - # have our results in return_val otherwise it's just URLs - if { $element ne "" - || [llength $filters] > 0} { - return $return_val - } else { - return $child_urls - } -} - ad_proc -public site_node::closest_ancestor_package { {-url ""} {-node_id ""} @@ -931,14 +389,17 @@ @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] } } + #ns_log notice "closest_ancestor_package still [list -url $url urlv [ns_conn urlv]]" # @@ -975,7 +436,6 @@ # move up a level set url [string trimright $url /] set url [string range $url 0 [string last / $url]] - set node [site_node::get -url $url] # are we looking for a specific package_key? @@ -990,36 +450,21 @@ } -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 -} { - if { [nsv_exists site_node_url_by_package_key $package_key] } { - return [lindex [nsv_get site_node_url_by_package_key $package_key] 0] - } else { - return {} - } -} - - ad_proc -public site_node::verify_folder_name { {-parent_node_id:required} {-current_node_id ""} {-instance_name ""} {-folder ""} } { - Verifies that the given folder name is valid for a folder under the given parent_node_id. - If current_node_id is supplied, it's assumed that we're renaming an existing node, not creating a new one. - If folder name is not supplied, we'll generate one from the instance name, which must then be supplied. - Returns folder name to use, or empty string if the supplied folder name wasn't acceptable. + + Verifies that the given folder name is valid for a folder under + the given parent_node_id. If current_node_id is supplied, it's + assumed that we're renaming an existing node, not creating a new + one. If folder name is not supplied, we'll generate one from the + instance name, which must then be supplied. + + @return folder name, or empty string if the supplied folder name wasn't acceptable. + } { set existing_urls [site_node::get_children -node_id $parent_node_id -element name] @@ -1069,1171 +514,916 @@ } return $folder } -##################################################################### -# old end of file -##################################################################### -if {$UseXotclSiteNodes} { +namespace eval ::acs { + ##################################################### + # @class acs::SiteNode + ##################################################### # - # If we are in this branch of the "if" statement, we want to use the - # XOTcl-based infrastructure. + # This class capsulates access to site-nodes stored in the + # database. It is written in a style to support the needs + # of the Tcl-based API above. # - # 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. - # + # @author Gustaf Neumann - namespace eval ::xo { + ::nx::Class create ::acs::SiteNode { - ##################################################### - # @class SiteNode - ##################################################### - # - # This class capsulates access to site-nodes stored in the - # database. It is written in a style to support the needs - # of the Tcl-based API above. - # - # @author Gustaf Neumann + :public method get { + {-url ""} + {-node_id ""} + } { + # + # @return a site node from url or site-node with all its context info + # - ::nx::Class create SiteNode { - - :public method get { - {-url ""} - {-node_id ""} - } { - # - # @return a site node from url or site-node with all its context info - # - - 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] + if {$url eq "" && $node_id eq ""} { + error "site_node::get \"must pass in either url or node_id\"" } # - # @method properties - # returns a site node from node_id with all its context info + # Make sure, we have a node_id. # + if {$node_id eq ""} { + set node_id [:get_node_id -url $url] + } - :protected method properties { - -node_id:integer,required - } { - # - # Get URL, since it is not returned by the later query. + return [:properties -node_id $node_id] + } - # TODO: I did not want to modify 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] + # + # @method properties + # returns a site node from node_id with all its context info + # - # - # get site-node with context from the database - # - ::db_1row dbqd.acs-tcl.tcl.site-nodes-procs.site_node::update_cache.select_site_node {} + :protected method properties { + -node_id:integer,required + } { + # + # Get URL, since it is not returned by the later query. - 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 - } + # TODO: I did not want to modify 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] # - # @method get_children - # get children of a site node + # get site-node with context from the database # + ::db_1row dbqd.acs-tcl.tcl.site-nodes-procs.site_node::update_cache.select_site_node {} - :public method get_children { - -node_id:required - -all:switch - {-package_type ""} - {-package_key ""} - {-filters ""} - {-element ""} - } { + 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 ""} + } { + # + # Filtering 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} { # - # Filtering 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. + # The following query is just for PG. Note that + # the query should not return the root of the + # tree. # - if {$all} { + set sql [subst { + WITH RECURSIVE site_node_tree(node_id, parent_id) AS ( + select node_id, parent_id from site_nodes where node_id = :node_id + UNION ALL + select child.node_id, child.parent_id from site_node_tree, site_nodes as child + where child.parent_id = site_node_tree.node_id + ) select [acs::dc map_function_name site_node__url(node_id)] + from site_node_tree where node_id != :node_id + }] + if {[db_driverkey ""] eq "oracle"} { + set sql [string map [list "WITH RECURSIVE" "WITH"] $sql] + } + + set child_urls [::acs::dc list -prepare integer [current method]-all $sql] + } else { + if {$package_key ne ""} { # - # The following query is just for PG. Note that - # the query should not return the root of the - # tree. + # Simple optimization for package_keys; seems to be frequently used. + # We leave the logic below unmodified, which could be optimized as well. # - set child_urls [::xo::dc list -prepare integer [current method]-all [subst { - WITH RECURSIVE site_node_tree AS ( - select node_id, parent_id from site_nodes where node_id = :node_id - UNION ALL - select child.node_id, child.parent_id from site_node_tree, site_nodes as child - where child.parent_id = site_node_tree.node_id - ) select [xo::dc map_function_name site_node__url(node_id)] - from site_node_tree where node_id != :node_id - }]] + set package_key_clause "and package_id = object_id and package_key = :package_key" + set from "site_nodes, apm_packages" } else { - if {$package_key ne ""} { - # - # Simple optimization for package_keys; seems to be frequently 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] + set package_key_clause "" + set from "site_nodes" } + set sql [subst { + select [::acs::dc map_function_name {site_node__url(node_id)}] + from $from + where parent_id = :node_id $package_key_clause + }] + set child_urls [::acs::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 { $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]}]} { + 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 - } + 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 - } + } + 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) - } + } + } 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 + } else { + set return_val $child_urls } - :method has_children { - -node_id:required,integer,1..1 - } { - # - # Check, if the provided site-node has children. - # - # @return boolean value. - # - # ns_log notice "non-cached version of has_children called with $node_id" + return $return_val + } - ::xo::dc get_value -prepare integer has_children { - select case when exists - (select 1 from site_nodes where parent_id = :node_id) - then 1 else 0 end - from dual - } - } - + :method has_children { + -node_id:required,integer,1..1 + } { # - # @method get_urls_from_object_id + # Check, if the provided site-node has children. # - # 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. + # @return boolean value. # + # ns_log notice "non-cached version of has_children called with $node_id" - :public method get_urls_from_object_id { - -object_id:required - } { - set child_urls [::xo::dc list -prepare integer [current method]-all [subst { - select [xo::dc map_function_name site_node__url(node_id)] as url - from site_nodes - where object_id = :object_id - order by url desc - }]] - } + set children [::acs::dc list -prepare integer has_children { + select 1 from site_nodes where parent_id = :node_id + FETCH NEXT 1 ROWS ONLY + }] + return [llength $children] + } - :public method get_urls_from_package_key { - -package_key:required - } { - # - # Return potentially multiple URLs based on a package key. - # - # @param package_key - # + # + # @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. + # - return [::xo::dc list -prepare varchar [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 - }] - } + :public method get_urls_from_object_id { + -object_id:required + } { + set child_urls [::acs::dc list -prepare integer [current method]-all [subst { + select [acs::dc map_function_name site_node__url(node_id)] as url + from site_nodes + where object_id = :object_id + order by url desc + }]] + } - :public method get_package_url { - -package_key:required - } { - # - # Legacy interface: previous implementations of the - # site-nodes assumed, that there is just one site-node - # entry available for a package-key. This method - # returns just the first answer form - # get_urls_from_package_key - # - return [lindex [:get_urls_from_package_key -package_key $package_key] 0] - } - + :public method get_urls_from_package_key { + -package_key:required + } { # - # @method get_node_id - # obtain node id from url, using directly the stored procedure - # site_node.node_id + # Return potentially multiple URLs based on a package key. # - # ::xo::db::sql::site_node node_id -url url ?-parent_id parent_id? + # @param package_key # - :public forward get_node_id ::xo::db::sql::site_node node_id + return [::acs::dc list -prepare varchar [current method]-urls-from-package-key [subst { + select [acs::dc map_function_name 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 + }]] + } + :public method get_package_url { + -package_key:required + } { # - # @method get_url - # obtain url from node-id, using directly the stored procedure - # site_node.url + # Legacy interface: previous implementations of the + # site-nodes assumed, that there is just one site-node + # entry available for a package-key. This method + # returns just the first answer form + # get_urls_from_package_key # - # ::xo::db::sql::site_node url -node_id node_id - # - :public forward get_url ::xo::db::sql::site_node url - - :public method flush_cache {-node_id:required,1..1 {-with_subtree:boolean} {-url ""}} { - # - # This is a stub method to be overloaded by some - # cache managers. - # - } - - # Create an object "xo::site_node" to provide a - # user-interface close to the classical one. - :create site_node + return [lindex [:get_urls_from_package_key -package_key $package_key] 0] } # - # For these URLs we assume that the site_node will never - # change, or require a broadcase flush, or reboot. + # @method get_node_id + # obtain node id from url, using directly the stored procedure + # site_node.node_id # - # TODO: make me configurable, after release of 5.10. - site_node eval { - set :static_site_nodes {/ 1 /dotlrn 1 /dotlrn/ 1 /register/ 1 /SYSTEM/ 1} - } + # ::acs::dc call site_node node_id -url url ?-parent_id parent_id? + # + :public forward get_node_id ::acs::dc call site_node node_id - ##################################################### - # Caching - ##################################################### + # + # @method get_url + # obtain url from node-id, using directly the stored procedure + # site_node.url + # + # ::acs::dc call site_node url -node_id node_id + # + :public forward get_url ::acs::dc call site_node url - if {[namespace which ::ns_cache_names] ne ""} { - set createCache [expr {"site_nodes_cache" ni [::ns_cache_names]}] - } else { - set createCache [catch {ns_cache flush site_nodes_cache NOTHING}] - } - if {$createCache} { + :public method flush_cache { + -node_id:required,1..1 + {-with_subtree:boolean} + {-url ""} + } { # - # Create caches. The sizes can be tailored in the config - # file like the following: + # This is a stub method to be overloaded by some + # cache managers. # - # ns_section ns/server/${server}/acs/acs-tcl - # ns_param SiteNodesCacheSize 10000000 - # ns_param SiteNodesCachePartitions 2 - # ns_param SiteNodesChildenCacheSize 10000000 - # ns_param SiteNodesChildenCachePartitions 2 - # ns_param SiteNodesIdCacheSize 200000 - # - ::acs::KeyPartitionedCache create ::acs::site_nodes_cache \ - -package_key acs-tcl \ - -parameter SiteNodesCache \ - -default_size 2000000 - # - # In case we have "ns_hash" defined, we can use the - # "HashKeyPartitionedCache". Otherwise fall back to the - # plain cache. - # - if {[::acs::icanuse "ns_hash"]} { - ::acs::HashKeyPartitionedCache create ::acs::site_nodes_id_cache \ - -package_key acs-tcl \ - -parameter SiteNodesIdCache \ - -default_size 100000 - } else { - ::acs::Cache create ::acs::site_nodes_id_cache \ - -package_key acs-tcl \ - -parameter SiteNodesIdCache \ - -default_size 100000 - } - - ::acs::KeyPartitionedCache create ::acs::site_nodes_children_cache \ - -package_key acs-tcl \ - -parameter SiteNodesChildenCache \ - -default_size 100000 } + # Create an object "acs::site_node" to provide a + # user-interface close to the classical one. + :create site_node + } + + # + # For these URLs we assume that the site_node will never + # change, or require a broadcast flush, or reboot. + # + # TODO: make me configurable, after release of 5.10. + site_node eval { + set :static_site_nodes {/ 1 /dotlrn 1 /dotlrn/ 1 /register/ 1 /SYSTEM/ 1} + } + + ##################################################### + # Caching + ##################################################### + + if {[namespace which ::ns_cache_names] ne ""} { + set createCache [expr {"site_nodes_cache" ni [::ns_cache_names]}] + } else { + set createCache [catch {ns_cache flush site_nodes_cache NOTHING}] + } + if {$createCache} { # - # SiteNodesCache 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. + # Create caches. The sizes can be tailored in the config + # file like the following: # - ::nx::Class create SiteNodesCache { + # ns_section ns/server/${server}/acs/acs-tcl + # ns_param SiteNodesCacheSize 10MB + # ns_param SiteNodesCachePartitions 2 + # ns_param SiteNodesChildenCacheSize 10MB + # ns_param SiteNodesChildenCachePartitions 2 + # ns_param SiteNodesIdCacheSize 200KB + # + ::acs::KeyPartitionedCache create ::acs::site_nodes_cache \ + -package_key acs-tcl \ + -parameter SiteNodesCache \ + -default_size 2MB + # + # In case we have "ns_hash" defined, we can use the + # "HashKeyPartitionedCache". Otherwise fall back to the + # plain cache. + # + if {[::acs::icanuse "ns_hash"]} { + ::acs::HashKeyPartitionedCache create ::acs::site_nodes_id_cache \ + -package_key acs-tcl \ + -parameter SiteNodesIdCache \ + -default_size 100KB + } else { + ::acs::Cache create ::acs::site_nodes_id_cache \ + -package_key acs-tcl \ + -parameter SiteNodesIdCache \ + -default_size 100KB + } - :public method get_children { - -node_id:required,integer,1..1 - {-all:switch} - {-package_type ""} - {-package_key ""} - {-filters ""} - {-element ""} - } { + ::acs::KeyPartitionedCache create ::acs::site_nodes_children_cache \ + -package_key acs-tcl \ + -parameter SiteNodesChildenCache \ + -default_size 100KB + } + + # + # acs::SiteNodesCache 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 ::acs::SiteNodesCache { + + :public method get_children { + -node_id:required,integer,1..1 + {-all:switch} + {-package_type ""} + {-package_key ""} + {-filters ""} + {-element ""} + } { + # + # Cache get_children operations, except, when "-all" + # was specified. The underlying operation can be quite + # expensive, when huge site-node trees are + # explored. Since the argument list influences the + # results, we cache for every parameter combination. + # + # Since this cache contains subtrees, we have to flush + # trees, which is implemented via pattern flushes. So + # we use a separate cache to avoid long locks on + # site-nodes in general. + # + if {$all} { # - # Cache get_children operations, except, when "-all" - # was specified. The underlying operation can be quite - # expensive, when huge site-node trees are - # explored. Since the argument list influences the - # results, we cache for every parameter combination. + # Don't cache when $all is specified - seldom + # used, a pain for invalidating. # - # Since this cache contains subtrees, we have to flush - # trees, which is implemented via pattern flushes. So - # we use a separate cache to avoid long locks on - # site-nodes in general. - # - if {$all} { - # - # Don't cache when $all is specified - seldom - # used, a pain for invalidating. - # - next - } else { - ::acs::site_nodes_children_cache eval -partition_key $node_id \ - get_children-$node_id-$all-$package_type-$package_key-$filters-$element { - next - } - } - } - - :method has_children { - -node_id:required,integer,1..1 - } { + next + } else { ::acs::site_nodes_children_cache eval -partition_key $node_id \ - has_children-$node_id { + get_children-$node_id-$all-$package_type-$package_key-$filters-$element { next } } + } - :public method get_node_id {-url:required} { - # - # Cache the result of the upstream implementation of - # get_node_id in the acs::site_nodes_id_cache cache. - # - acs::site_nodes_id_cache eval id-$url { next } - } - - :protected method properties {-node_id:required,integer,1..1} { - return [acs::per_request_cache eval -key acs-tcl.site_nodes_property-$node_id { - ::acs::site_nodes_cache eval -partition_key $node_id $node_id { next } - }] - } - - :public method get_url {-node_id:required,1..1} { - # - # It's a pain, but OpenACS and its regression test - # call "get_url" a few times with an empty node_id. - # Shortcut these calls here to avoid problems with the - # non-numeric partition_key. - # - if {$node_id eq ""} { - set result "" - } else { - set result [::acs::site_nodes_cache eval \ - -partition_key $node_id \ - url-$node_id { next }] + :method has_children { + -node_id:required,integer,1..1 + } { + ::acs::site_nodes_children_cache eval -partition_key $node_id \ + has_children-$node_id { + next } - return $result - } + } - :public method get_urls_from_object_id {-object_id:required,integer,1..1} { - # - # Cache the result of the upstream implementation of - # get_urls_from_object_id in the acs::site_nodes_cache. - # - ::acs::site_nodes_cache eval -partition_key $object_id urls-$object_id { next } - } + :public method get_node_id {-url:required} { + # + # Cache the result of the upstream implementation of + # get_node_id in the acs::site_nodes_id_cache cache. + # + acs::site_nodes_id_cache eval id-$url { next } + } - :public method get_package_url {-package_key:required} { - # - # Cache the result of the upstream implementation of - # get_package_url in the acs::site_nodes_cache. - # - # Note: The cache value from the following method is - # currently not flushed, but just used for package - # keys, not instances, so it should be safe. - # - ::acs::site_nodes_cache eval -partition_key 0 package_url-$package_key { next } - } + :protected method properties {-node_id:required,integer,1..1} { + return [acs::per_request_cache eval -key acs-tcl.site_nodes_property-$node_id { + ::acs::site_nodes_cache eval -partition_key $node_id $node_id { next } + }] + } - :method flush_per_request_cache {} { - array unset ::__node_id + :public method get_url {-node_id:required,1..1} { + # + # It's a pain, but OpenACS and its regression test + # call "get_url" a few times with an empty node_id. + # Shortcut these calls here to avoid problems with the + # non-numeric partition_key. + # + if {$node_id eq ""} { + set result "" + } else { + set result [::acs::site_nodes_cache eval \ + -partition_key $node_id \ + url-$node_id { next }] } + return $result + } - :public method flush_pattern {{-partition_key ""} pattern} { - # - # Flush from the site-nodes caches certain - # information. The method hides the actual caching - # structure and is as well provided in conformance - # with the alternative implementations - # above. Depending on the specified pattern, it - # reroutes the flushing request to different caches. - # + :public method get_urls_from_object_id {-object_id:required,integer,1..1} { + # + # Cache the result of the upstream implementation of + # get_urls_from_object_id in the acs::site_nodes_cache. + # + ::acs::site_nodes_cache eval -partition_key $object_id urls-$object_id { next } + } - :flush_per_request_cache + :public method get_package_url {-package_key:required} { + # + # Cache the result of the upstream implementation of + # get_package_url in the acs::site_nodes_cache. + # + # Note: The cache value from the following method is + # currently not flushed, but just used for package + # keys, not instances, so it should be safe. + # + ::acs::site_nodes_cache eval -partition_key 0 package_url-$package_key { next } + } - switch -glob -- $pattern { - id-* {set cache site_nodes_id_cache} - get_children-* - - has_children {set cache site_nodes_children_cache} - default {set cache site_nodes_cache} - } - ::acs::$cache flush_pattern -partition_key $partition_key $pattern - } + :method flush_per_request_cache {} { + array unset ::__node_id + } - :public method flush_cache {-node_id:required,1..1 {-with_subtree:boolean true} {-url ""}} { - # - # 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. - # + :public method flush_pattern {{-partition_key ""} pattern} { + # + # Flush from the site-nodes caches certain + # information. The method hides the actual caching + # structure and is as well provided in conformance + # with the alternative implementations + # above. Depending on the specified pattern, it + # reroutes the flushing request to different caches. + # - :flush_per_request_cache + :flush_per_request_cache - set old_url [:get_url -node_id $node_id] - - if {$node_id eq "" || $old_url eq "/"} { - # - # When no node_id is given or the URL is specified - # as top-url, flush all caches. This happens - # e.g. in the regression test. - # - #ns_log notice "FLUSHALL" - ::acs::site_nodes_cache flush_all - ::acs::site_nodes_id_cache flush_all - ::acs::site_nodes_children_cache flush_all - - } else { - # - # Get subtree from db - # - set tree [::xo::dc list_of_lists -prepare {integer boolean} get_subtree [subst { - WITH RECURSIVE site_node_tree AS ( - select node_id, parent_id, object_id from site_nodes where node_id = :node_id - UNION ALL - select child.node_id, child.parent_id, child.object_id from site_node_tree, site_nodes as child - where child.parent_id = site_node_tree.node_id - and :with_subtree - ) select [xo::dc map_function_name site_node__url(node_id)], node_id, object_id from site_node_tree - }]] - foreach entry $tree { - lassign $entry url node_id object_id - foreach key [list $node_id url-$node_id] { - ::acs::site_nodes_cache flush -partition_key $node_id $key - } - if {$object_id ne ""} { - ::acs::site_nodes_cache flush -partition_key $object_id urls-$object_id - } - :flush_pattern -partition_key $node_id get_children-$node_id-* - ::acs::site_nodes_children_cache flush -partition_key $node_id has_children-$node_id - } - regsub {/$} $old_url "" old_url - :flush_pattern id-$old_url* - } + switch -glob -- $pattern { + id-* {set cache site_nodes_id_cache} + get_children-* - + has_children {set cache site_nodes_children_cache} + default {set cache site_nodes_cache} } + ::acs::$cache flush_pattern -partition_key $partition_key $pattern } - ::nx::Class create SiteNodeUrlspaceCache { + :public method flush_cache { + -node_id:required,1..1 + {-with_subtree:boolean true} + {-url ""} + } { # - # Cache site-node information via ns_urlspace. We can use - # the URL trie, which supports tree match operations, for - # tree information. This means that for example for .vuh - # handlers it is not necessary to cache the full url for - # obtaining the site-node, like it was until now: + # 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. # - # 3839 id-/storage/view/installers/windows-installer/installer.htm - # 3839 id-/storage/view/aolserver/install.tgz - # 3839 id-/storage/view/tutorial/OpenACS_Tutorial.htm - # 3839 id-/storage/view/openacs-dotlrn-conference-2007-spring/Methodology_ALPE.pdf - # 3839 id-/storage/view/xowiki-resources/Assessment.jpg - # 3839 id-/storage/view/tutorial-page-map.png - # ... - # - # Providing a single entry like - # - # ns_urlspace set -key sitenode /storage/* 3839 - # - # is sufficient for replacing all entries above. - # - :public method get_node_id {-url:required} { - # - # Get node_id for the provided URL. We have to - # determine the partial URL for determining the site - # node. - # - # @return node_id (integer) - # + :flush_per_request_cache + set old_url [:get_url -node_id $node_id] + + if {$node_id eq "" || $old_url eq "/"} { # - # This is the main interface of the - # SiteNodeUrlspaceCache to provide a first-level - # cache. + # When no node_id is given or the URL is specified + # as top-url, flush all caches. This happens + # e.g. in the regression test. # + #ns_log notice "FLUSHALL" + ::acs::site_nodes_cache flush_all + ::acs::site_nodes_id_cache flush_all + ::acs::site_nodes_children_cache flush_all - # Try per-request caching + } else { # - if {[dict exists ${:static_site_nodes} $url]} { - set key :node_id($url) - } else { - set key ::__node_id($url) + # Get subtree from db + # + set sql [subst { + WITH RECURSIVE site_node_tree(node_id,parent_id,object_id) AS ( + select node_id, parent_id, object_id from site_nodes where node_id = :node_id + UNION ALL + select child.node_id, child.parent_id, child.object_id from site_node_tree, site_nodes as child + where child.parent_id = site_node_tree.node_id + and :with_subtree + ) + select [acs::dc map_function_name site_node__url(node_id)], node_id, object_id + from site_node_tree + }] + if {[db_driverkey ""] eq "oracle"} { + set sql [string map [list "WITH RECURSIVE" "WITH"] $sql] } - if {[info exists $key]} { - #ns_log notice "==== returning cached value [set $key]" - return [set $key] - } - # - # Try to get value from urlspace - # - set ID [ns_urlspace get -id $::acs::siteNodesID -key sitenode $url] - if {$ID eq ""} { - # - # Get value the classical way, caching potentially - # the full url path in the site_nodes_id_cache. - # - set ID [next] - #ns_log notice "--- get_node_id from site_nodes_id_cache <$url> -> <$ID>" - if {$ID ne ""} { - # - # We got a valid ID. If we would add blindly a - # node_id for the returned URL (e.g. for "/*") - # and some other subnode is not jet resolved, - # we would obtain later the node_id of the - # parent_node although there is a subnode. - # - # We could address this by e.g. pre-caching - # all "inner nodes" or similar, but this - # requires a deeper analysis of larger sites. - # - # In earlier versions, we had here - # ... {[site_node::get_children -node_id $ID] eq ""} ... - # but on site_node trees with huge number of entries, - # this is a waste. - # - if {![:has_children -node_id $ID]} { - # - # We are on a leaf-node of the site node - # tree. Get the shortened url and save it - # in the urlspace. - # - set short_url [site_node::get_url -node_id $ID] - set cmd [list ns_urlspace set -id $::acs::siteNodesID -key sitenode $short_url* $ID] - #ns_log notice "--- get_node_id save in urlspace <$cmd> -> <$ID>" - {*}$cmd - #ns_log notice "---\n[join [ns_urlspace list -id $::acs::siteNodesID] \n]" - } - return [set $key $ID] + set tree [::acs::dc list_of_lists -prepare {integer boolean} get_subtree $sql] + + foreach entry $tree { + lassign $entry url node_id object_id + foreach key [list $node_id url-$node_id] { + ::acs::site_nodes_cache flush -partition_key $node_id $key } + if {$object_id ne ""} { + ::acs::site_nodes_cache flush -partition_key $object_id urls-$object_id + } + :flush_pattern -partition_key $node_id get_children-$node_id-* + ::acs::site_nodes_children_cache flush \ + -partition_key $node_id \ + has_children-$node_id } - return $ID + regsub {/$} $old_url "" old_url + :flush_pattern id-$old_url* } - - :public method flush_cache {-node_id:required,1..1 {-with_subtree:boolean true} {-url ""}} { - # - # Cleanup in the urlspace tree: Clear always the - # full subtree via "-recurse" (maybe not always - # necessary). - # - - ::acs::clusterwide ns_urlspace unset -id $::acs::siteNodesID -recurse -key sitenode $url - next - } - - - } - site_node object mixins add SiteNodesCache - if {[namespace which ns_urlspace] ne ""} { - set ::acs::siteNodesID [ns_urlspace new] - ns_log notice \ - "... using ns_urlspace $::acs::siteNodesID for reduced redundancy in site node caches" - site_node object mixins add SiteNodeUrlspaceCache } - } - ##################################################################### - # 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 {} - + ::nx::Class create ::acs::SiteNodeUrlspaceCache { # - # We have to flush from the parent_url (which might be a leaf - # turning into an inner node) + # Cache site-node information via ns_urlspace. We can use + # the URL trie, which supports tree match operations, for + # tree information. This means that for example for .vuh + # handlers it is not necessary to cache the full url for + # obtaining the site-node, like it was until now: # - set parent_node_id [site_node::get_parent_id -node_id $node_id] - set url [site_node::get_url -node_id $parent_node_id] - - site_node::update_cache -sync_children -node_id $node_id -url $url -object_id $object_id + # 3839 id-/storage/view/installers/windows-installer/installer.htm + # 3839 id-/storage/view/aolserver/install.tgz + # 3839 id-/storage/view/tutorial/OpenACS_Tutorial.htm + # 3839 id-/storage/view/openacs-dotlrn-conference-2007-spring/Methodology_ALPE.pdf + # 3839 id-/storage/view/xowiki-resources/Assessment.jpg + # 3839 id-/storage/view/tutorial-page-map.png + # ... # - # The parent_node_id should in a mount operation never be - # empty. + # Providing a single entry like # - ::acs::site_nodes_cache flush_pattern \ - -partition_key $parent_node_id \ - get_children-$parent_node_id-* - ::acs::site_nodes_children_cache flush \ - -partition_key $parent_node_id has_children-$parent_node_id - + # ns_urlspace set -key sitenode /storage/* 3839 # - # 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. + # is sufficient for replacing all entries above. # - if {[info exists context_id]} { - db_dml update_package_context_id { - update acs_objects - set context_id = :context_id - where object_id = :object_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] - } - } + :public method get_node_id {-url:required} { + # + # Get node_id for the provided URL. We have to + # determine the partial URL for determining the site + # node. + # + # @return node_id (integer) + # - ad_proc -private site_node::init_cache {} { - Initialize the site node cache; actually, this means flushing the - cache in case we have a root site node. - } { - #ns_log notice "site_node::init_cache" - if {[db_0or1row get_root_node { - select node_id as root_node_id - from site_nodes - where parent_id is null - }]} { # - # 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. + # This is the main interface of the + # SiteNodeUrlspaceCache to provide a first-level + # cache. # - if {[namespace which ::xo::db::sql::site_node] ne ""} { - #ns_log notice "call [list ::xo::site_node flush_cache -node_id $root_node_id]" - ::xo::site_node flush_cache -node_id $root_node_id + + # Try per-request caching + # + if {[dict exists ${:static_site_nodes} $url]} { + set key :node_id($url) + } else { + set key ::__node_id($url) } + if {[info exists $key]} { + #ns_log notice "==== returning cached value [set $key]" + return [set $key] + } + + # + # Try to get value from urlspace + # + set ID [ns_urlspace get -id $::acs::siteNodesID -key sitenode $url] + if {$ID eq ""} { + # + # Get value the classical way, caching potentially + # the full url path in the site_nodes_id_cache. + # + set ID [next] + #ns_log notice "--- get_node_id from site_nodes_id_cache <$url> -> <$ID>" + if {$ID ne ""} { + # + # We got a valid ID. If we would add blindly a + # node_id for the returned URL (e.g. for "/*") + # and some other subnode is not jet resolved, + # we would obtain later the node_id of the + # parent_node although there is a subnode. + # + # We could address this by e.g. pre-caching + # all "inner nodes" or similar, but this + # requires a deeper analysis of larger sites. + # + # In earlier versions, we had here + # ... {[site_node::get_children -node_id $ID] eq ""} ... + # but on site_node trees with huge number of entries, + # this is a waste. + # + if {![:has_children -node_id $ID]} { + # + # We are on a leaf-node of the site node + # tree. Get the shortened url and save it + # in the urlspace. + # + set short_url [site_node::get_url -node_id $ID] + set cmd [list ns_urlspace set -id $::acs::siteNodesID -key sitenode $short_url* $ID] + #ns_log notice "--- get_node_id save in urlspace <$cmd> -> <$ID>" + {*}$cmd + #ns_log notice "---\n[join [ns_urlspace list -id $::acs::siteNodesID] \n]" + } + return [set $key $ID] + } + } + return $ID } - #ns_log notice "site_node::init_cache $root_node_id DONE" - } - ad_proc -public site_node::update_cache { - {-sync_children:boolean} - {-node_id:required} - {-url ""} - {-object_id ""} - } { - 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 -url $url + :public method flush_cache { + -node_id:required,1..1 + {-with_subtree:boolean true} + {-url ""} + } { + # + # Cleanup in the urlspace tree: Clear always the + # full subtree via "-recurse" (maybe not always + # necessary). + # - set parent_node_id [site_node::get_parent_id -node_id $node_id] - if {$parent_node_id ne ""} { - ::xo::site_node flush_pattern -partition_key $parent_node_id get_children-$parent_node_id-* + ::acs::clusterwide ns_urlspace unset -id $::acs::siteNodesID -recurse -key sitenode $url + next } - # - # In case update_cache is called after the deletion of the node - # in the database, it is still necessary to flush for the - # original object_id, but this can't be handled in the - # recursive query of method "flush_cache". - # - if {$object_id ne ""} { - ::acs::site_nodes_cache flush -partition_key $object_id urls-$object_id - } - } - 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] } + site_node object mixins add SiteNodesCache + if {[namespace which ns_urlspace] ne ""} { + set ::acs::siteNodesID [ns_urlspace new] + ns_log notice \ + "... using ns_urlspace $::acs::siteNodesID for reduced redundancy in site node caches" + site_node object mixins add SiteNodeUrlspaceCache + } - 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.
+# +# Plain Tcl API using the definitons from above +# +ad_proc -public site_node::new { + {-name:required} + {-parent_id:required} + {-directory_p t} + {-pattern_p t} +} { + Create a new site node - 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.
+ @return node_id +} { + set var_list [list \ + [list name $name] \ + [list parent_id $parent_id] \ + [list directory_p $directory_p] \ + [list pattern_p $pattern_p]] - @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]] - } + set node_id [package_instantiate_object -var_list $var_list site_node] + return $node_id +} - ad_proc -public site_node::exists_p { - {-url:required} - } { - Returns 1 if a site node exists at the given url and 0 otherwise. +ad_proc -public site_node::mount { + {-node_id:required} + {-object_id:required} + {-context_id} +} { + mount object at site node +} { - @param url URL path starting with a slash. - } { - set url_no_trailing [expr {$url eq "/" ? "/" : [string trimright $url "/"]}] - # - # The function "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/"}] - } + db_dml mount_object {} + db_dml update_object_package_id {} - ad_proc -public site_node::get_url { - {-node_id:required} - {-notrailing:boolean} - } { - return the url of this node_id + # + # We have to flush from the parent_url (which might be a leaf + # turning into an inner node) + # + set parent_node_id [site_node::get_parent_id -node_id $node_id] + set url [site_node::get_url -node_id $parent_node_id] - @param 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 "/"] + site_node::update_cache -sync_children -node_id $node_id -url $url -object_id $object_id + # + # The parent_node_id should in a mount operation never be + # empty. + # + ::acs::site_nodes_cache flush_pattern \ + -partition_key $parent_node_id \ + get_children-$parent_node_id-* + ::acs::site_nodes_children_cache flush \ + -partition_key $parent_node_id has_children-$parent_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 { + update acs_objects + set context_id = :context_id + where object_id = :object_id } - 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 + 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 -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 - a 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 packages 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 -private site_node::init_cache {} { + Initialize the site node cache; actually, this means flushing the + cache in case we have a root site node. +} { + #ns_log notice "site_node::init_cache" + if {[db_0or1row get_root_node { + select node_id as root_node_id + from site_nodes + where parent_id is null + }]} { + # + # 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. + # + ::acs::site_node flush_cache -node_id $root_node_id } + #ns_log notice "site_node::init_cache $root_node_id DONE" +} - 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. +ad_proc -public site_node::update_cache { + {-sync_children:boolean} + {-node_id:required} + {-url ""} + {-object_id ""} +} { + Brings the in-memory copy of the site nodes hierarchy in sync with the + database version. Only updates the given node and its children. +} { + ::acs::site_node flush_cache \ + -node_id $node_id \ + -with_subtree $sync_children_p \ + -url $url - 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] + set parent_node_id [site_node::get_parent_id -node_id $node_id] + if {$parent_node_id ne ""} { + ::acs::site_node flush_pattern \ + -partition_key $parent_node_id \ + get_children-$parent_node_id-* } - ad_proc -deprecated -warn site_node_closest_ancestor_package { - { -default "" } - { -url "" } - package_keys - } { -
- Use site_node::closest_ancestor_package. Note that - site_node_closest_ancestor_package will include the passed-in node in the - search, whereas the new proc doesn't by default. If you want to include - the passed-in node, call site_node::closest_ancestor_package with the - -include_self flag -
- -- Finds the package id of a package of specified type that is - closest to the node id represented by url (or by ad_conn url).Note - that closest means the nearest ancestor node of the specified - type, or the current node if it is of the correct type. - -
- - Usage: - -
- # Pull out the package_id of the subsite closest to our current node - set pkg_id [site_node::closest_ancestor_package -include_self -package_key "acs-subsite"] -- - @param default The value to return if no package can be found - @param url The url of 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.
+ # In case update_cache is called after the deletion of the node
+ # in the database, it is still necessary to flush for the
+ # original object_id, but this can't be handled in the
+ # recursive query of method "flush_cache".
#
+ if {$object_id ne ""} {
+ ::acs::site_nodes_cache flush -partition_key $object_id urls-$object_id
+ }
+}
- # temporary helper for testing in ds/shell
- #
- #array set top [site_node::get -url /]
- #array set ds [site_node::get -url /ds]
- ##set n [site_node::new -name a2 -parent_id $ds(node_id)]
- #array set a2 [site_node::get -url /ds/a2]
- #set n $a2(node_id)
+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 [::acs::site_node get -url $url -node_id $node_id]
+}
- #site_node::get_children -package_key attachments -node_id $ds(node_id)
- #site_node::get_children -package_key attachments -node_id $top(node_id)
- #foreach k [ns_cache_keys xo_site_nodes get_children*] {lappend _ $k=[ns_cache_get xo_site_nodes $k]}
+ad_proc -public site_node::get_from_url {
+ {-url:required}
+ {-exact:boolean}
+} {
+ Returns an array representing the site node that matches the given url.
- #site_node::mount -node_id $n -object_id 1226
- #site_node::unmount -node_id $n
+ A trailing '/' will be appended to $url if required and not present.
- #set _
+ 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 [::acs::site_node get -node_id [::acs::site_node get_node_id -url $url]]
}
-
-########################################################################
-# deprecated site-nodes-procs.tcl
-########################################################################
-
-ad_proc -deprecated site_node_delete_package_instance {
- {-node_id:required}
+ad_proc -public site_node::exists_p {
+ {-url:required}
} {
- Wrapper for apm_package_instance_delete
+ Returns 1 if a site node exists at the given url and 0 otherwise.
- @author Arjun Sanyal (arjun@openforc.net)
- @creation-date 2002-05-02
- @see site_node::delete
+ @param url URL path starting with a slash.
} {
- db_transaction {
- set package_id [site_node::get_object_id -node_id $node_id]
- site_node::unmount -node_id $node_id
- apm_package_instance_delete $package_id
- } on_error {
- site_node::update_cache -node_id $node_id
- }
+ set url_no_trailing [expr {$url eq "/" ? "/" : [string trimright $url "/"]}]
+ #
+ # The function "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 [::acs::site_node get_node_id -url $url_no_trailing]
+ return [expr {[::acs::site_node get_url -node_id $node_id] eq "$url_no_trailing/"}]
}
-ad_proc -deprecated site_map_unmount_application {
- { -sync_p "t" }
- { -delete_p "f" }
- node_id
+ad_proc -public site_node::get_url {
+ {-node_id:required}
+ {-notrailing:boolean}
} {
- Unmounts the specified node.
+ return the url of this node_id
- @author Michael Bryzek (mbryzek@arsdigita.com)
- @creation-date 2001-02-07
-
- @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
- @param node_id The node_id to unmount
- @see site_node::unmount
-
+ @param notrailing If true then strip any trailing slash ('/').
+ This means the empty string is returned for the root.
} {
- db_transaction {
- site_node::unmount -node_id $node_id
-
- if {$delete_p == "t"} {
- site_node::delete -node_id $node_id
- }
+ set url [::acs::site_node get_url -node_id $node_id]
+ if { $notrailing_p } {
+ set url [string trimright $url "/"]
}
+ return $url
}
-ad_proc -deprecated site_node_id {url} {
- Returns the node_id of a site node. Throws an error if there is no
- matching node.
- @see site_node::get_node_id
+ad_proc -public site_node::get_url_from_object_id {
+ {-object_id:required}
} {
- return [site_node::get_node_id -url $url]
-}
-
-ad_proc -deprecated site_nodes_sync {args} {
- Brings the in-memory copy of the url hierarchy in sync with the
- database version.
-
- @see site_node::init_cache
+ 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.
} {
- site_node::init_cache
+ ::acs::site_node get_urls_from_object_id -object_id $object_id
}
-ad_proc -deprecated -warn site_node_closest_ancestor_package {
- { -default "" }
- { -url "" }
- package_keys
+ad_proc -public site_node::get_children {
+ {-all:boolean}
+ {-package_type {}}
+ {-package_key {}}
+ {-filters {}}
+ {-element {}}
+ {-node_id:required}
} {
- - 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. + 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. - Usage: + @option all Set this if you want all children, not just direct children -
- # Pull out the package_id of the subsite closest to our current node - set pkg_id [site_node::closest_ancestor_package -include_self -package_key "acs-subsite"] -+ @option package_type If specified, this will limit the returned nodes to those with + a package of the specified package type (normally apm_service or + apm_application) mounted. Conflicts with the -package_key option. - @author Michael Bryzek (mbryzek@arsdigita.com) - @creation-date 1/17/2001 + @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 packages keys as a Tcl list. - @param default The value to return if no package can be found - @param url The url of the node from which to start the search - @param package_keys The type(s) of the package(s) for which we are looking + @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" }. - @return
package_id of the nearest package of the
- specified type (package_key). Returns $default if no
- such package can be found.
+ @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.
- @see site_node::closest_ancestor_package
+ @return A list of URLs of the site_nodes immediately under this site node, or all children,
+ if the -all switch is specified.
} {
- if {$url eq ""} {
- set url [ad_conn url]
- }
-
- # 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)
- }
- }
-
- # 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)
- }
- }
- }
-
- # Try successively shorter prefixes.
- while {$url ne ""} {
- # Chop off last component and try again.
- set url [string trimright $url /]
- set url [string range $url 0 [string last / $url]]
-
- if {[catch {nsv_get site_nodes $url} result] == 0} {
- array set node $result
- if {$node(pattern_p) == "t"
- && $node(object_id) ne ""
- && $node(package_key) in $package_keys
- } {
- return $node(package_id)
- }
- }
- }
-
- return $default
+ ::acs::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 -deprecated site_node_closest_ancestor_package_url {
- { -default "" }
- { -package_key {} }
+ad_proc -public site_node::get_package_url {
+ {-package_key:required}
} {
- Returns the url stub of the nearest application of the specified
- type.
+ Get the URL of any mounted instance of a package with the given package_key.
- @author Michael Bryzek (mbryzek@arsdigita.com)
- @creation-date 2001-02-05
+ 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.
- @param package_key The types of packages for which we're looking (defaults to subsite packages)
- @param default The default value to return if no package of the
- specified type was found
-
- @see site::node::closest_ancestor_package
+ @return a URL, or empty string if no instance of the package is mounted.
+ @see site_node::get_children
} {
- if {$package_key eq ""} {
- set package_key [subsite::package_keys]
- }
-
- set subsite_pkg_id [site_node::closest_ancestor_package \
- -include_self \
- -package_key $package_key \
- -url [ad_conn url] ]
-
- if {$subsite_pkg_id eq ""} {
- # No package was found... return the default
- return $default
- }
-
- return [lindex [site_node::get_url_from_object_id -object_id $subsite_pkg_id] 0]
+ return [::acs::site_node get_package_url -package_key $package_key]
}
-ad_proc -deprecated 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.
- @see ad_conn
-} {
- set ns_conn_url [ns_conn url]
- set subsite_get_url [subsite::get_url]
- set joined_url [ad_file join $subsite_get_url $ns_conn_url]
- # join drops ending slash for some cases. Add back if appropriate.
- if { [string index $ns_conn_url end] eq "/" && [string index $joined_url end] ne "/" } {
- append joined_url "/"
- }
- return $joined_url
-}
#
# Local variables: