Index: openacs-4/packages/acs-subsite/tcl/subsite-procs-oracle.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-subsite/tcl/subsite-procs-oracle.xql,v
diff -u -N -r1.5 -r1.6
--- openacs-4/packages/acs-subsite/tcl/subsite-procs-oracle.xql 14 Dec 2003 11:57:27 -0000 1.5
+++ openacs-4/packages/acs-subsite/tcl/subsite-procs-oracle.xql 18 Feb 2005 19:08:52 -0000 1.6
@@ -72,4 +72,17 @@
+
+
+ and rownum < 2
+ order by decode(host, :search_vhost, 1, 0) desc
+
+
+
+
+
+ and rownum < 2
+
+
+
Index: openacs-4/packages/acs-subsite/tcl/subsite-procs-postgresql.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-subsite/tcl/subsite-procs-postgresql.xql,v
diff -u -N -r1.7 -r1.8
--- openacs-4/packages/acs-subsite/tcl/subsite-procs-postgresql.xql 14 Dec 2003 11:57:28 -0000 1.7
+++ openacs-4/packages/acs-subsite/tcl/subsite-procs-postgresql.xql 18 Feb 2005 19:08:52 -0000 1.8
@@ -74,4 +74,18 @@
+
+
+ order by case when host = :search_vhost then 1
+ else 0 end desc
+ limit 1
+
+
+
+
+
+ limit 1
+
+
+
Index: openacs-4/packages/acs-subsite/tcl/subsite-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-subsite/tcl/subsite-procs.tcl,v
diff -u -N -r1.28 -r1.29
--- openacs-4/packages/acs-subsite/tcl/subsite-procs.tcl 26 Jan 2005 00:53:38 -0000 1.28
+++ openacs-4/packages/acs-subsite/tcl/subsite-procs.tcl 18 Feb 2005 19:08:52 -0000 1.29
@@ -734,3 +734,157 @@
}
}
}
+
+ad_proc -public subsite::get_url {
+ {-node_id ""}
+ {-absolute_p 0}
+ {-force_host ""}
+ {-strict_p 0}
+ {-protocol ""}
+ {-port ""}
+} {
+ Returns the url stub for the specified subsite.
+
+ If -absolute is supplied then this function will generate absolute urls.
+
+ If the site is currently being accessed via a host node mapping or
+ -force_host_node_map is also supplied then URLs will ommit the
+ corresponding subsite url stub. The host name will be used
+ for any appropriate subsite when absolute urls are generated.
+
+ @param node_id the subsite's node_id (defaults to nearest subsite node).
+ @param absolute_p whether to include the host in the returned url.
+ @param force_host_node_map_p whether to produce host node mapped urls
+ regardless of the current connection state
+} {
+ if {[ad_conn isconnected]} {
+ if {[string equal $node_id ""]} {
+ set node_id [ad_conn subsite_node_id]
+ }
+
+ array set subsite_node [site_node::get -node_id $node_id]
+
+ set main_host [ns_config \
+ "ns/server/[ns_info server]/module/nssock" \
+ Hostname]
+
+ util_driver_info -array request
+
+ set headers [ns_conn headers]
+ set host_addr [split [ns_set iget $headers host] :]
+ set request(vhost) [lindex $host_addr 0]
+
+ if {![string equal [lindex $host_addr 1] ""]} {
+ set request(port) [lindex $host_addr 1]
+ }
+
+ set request_vhost_p [expr {![string equal $main_host $request(vhost)]}]
+ } else {
+ if {[string equal $node_id ""]} {
+ error "You must supply node_id when not connected."
+ } else {
+ array set subsite_node [site_node::get -node_id $node_id]
+ }
+
+ set request_vhost_p 0
+ }
+
+ set default_port(http) 80
+ set default_port(https) 443
+
+ set force_host_p [expr {![string equal $force_host ""]}]
+
+ set force_protocol_p [expr {![string equal $protocol ""]}]
+ if {!$force_protocol_p} {
+ set protocol http
+ }
+
+ set force_port_p [expr {![string equal $port ""]}]
+ if {!$force_port_p} {
+ set port 80
+ }
+
+ set result ""
+
+ if {$request_vhost_p ||
+ $force_host_p} {
+ set root_p [string equal $subsite_node(parent_id) ""]
+ set search_vhost $force_host
+ set mapped_vhost ""
+
+ set where_clause [db_map strict_search]
+
+ # Figure out which hostname to use
+ if {!$force_host_p} {
+ set search_vhost $request(vhost)
+ } elseif {[string equal $force_host "any"]} {
+ if {$request_vhost_p} {
+ set search_vhost $request(vhost)
+ set where_clause [db_map orderby]
+ } else {
+ set where_clause [db_map simple_search]
+ }
+ }
+
+ # TODO: This should be cached
+ set site_node $subsite_node(node_id)
+ set mapped_vhost [db_string get_vhost {} -default ""]
+
+ if {$root_p && [string equal $mapped_vhost ""]} {
+ if {$strict_p} {
+ error "$search_vhost is not mapped to this subsite or any of its parents."
+ }
+
+ if {[string equal $search_vhost "any"]} {
+ set mapped_vhost $main_host
+ } else {
+ set mapped_vhost $search_vhost
+ }
+ }
+
+ if {[string equal $mapped_vhost ""]} {
+ set result "[subsite::get_url \
+ -node_id $subsite_node(parent_id) \
+ -absolute_p $absolute_p \
+ -strict_p $strict_p \
+ -force_host $force_host]$subsite_node(name)/"
+ } else {
+ if {[ad_conn isconnected] &&
+ [string equal $mapped_vhost $request(vhost)]} {
+ if {!$force_protocol_p} {
+ set protocol $request(proto)
+ }
+
+ if {!$force_port_p} {
+ set port $request(port)
+ }
+ }
+
+ if {$absolute_p} {
+ set result "${protocol}://${mapped_vhost}"
+
+ if {![string equal $port $default_port($protocol)]} {
+ append result ":$port"
+ }
+
+ append result "/"
+ } else {
+ set result "/"
+ }
+ }
+ } else {
+ if {$absolute_p} {
+ set result "${protocol}://${main_host}"
+
+ if {![string equal $port $default_port($protocol)]} {
+ append result ":$port"
+ }
+
+ append result "/"
+ }
+
+ append result "$subsite_node(url)"
+ }
+
+ return $result
+}
Index: openacs-4/packages/acs-subsite/tcl/subsite-procs.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-subsite/tcl/Attic/subsite-procs.xql,v
diff -u -N -r1.5 -r1.6
--- openacs-4/packages/acs-subsite/tcl/subsite-procs.xql 11 Dec 2003 21:39:55 -0000 1.5
+++ openacs-4/packages/acs-subsite/tcl/subsite-procs.xql 18 Feb 2005 19:08:52 -0000 1.6
@@ -59,5 +59,21 @@
+
+
+
+ select host
+ from host_node_map
+ where node_id = :node_id
+ $where_clause
+
+
+
+
+
+ and host = :search_vhost
+
+
+
Index: openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl,v
diff -u -N -r1.70 -r1.71
--- openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl 17 Feb 2005 15:11:39 -0000 1.70
+++ openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl 18 Feb 2005 19:08:53 -0000 1.71
@@ -600,6 +600,7 @@
}
ad_conn -set node_id $node(node_id)
+ ad_conn -set node_name $node(name)
ad_conn -set object_id $node(object_id)
ad_conn -set object_url $node(url)
ad_conn -set object_type $node(object_type)
@@ -1219,14 +1220,32 @@
-default {en_US}]
return $ad_conn(locale)
}
- subsite_id {
- set ad_conn(subsite_id) [site_node::closest_ancestor_package \
+ subsite_node_id {
+ set ad_conn(subsite_node_id) [site_node::closest_ancestor_package \
-node_id [ad_conn node_id] \
-package_key "acs-subsite" \
-include_self \
- -element "package_id"]
+ -element "node_id"]
+ return $ad_conn(subsite_node_id)
+ }
+ subsite_id {
+ set ad_conn(subsite_id) [site_node::get_object_id \
+ -node_id [ad_conn subsite_node_id]]
return $ad_conn(subsite_id)
}
+ subsite_url {
+ set ad_conn(subsite_url) [site_node::get_url \
+ -node_id [ad_conn subsite_node_id]]
+ return $ad_conn(node_id)
+ }
+ vhost_subsite_url {
+ set ad_conn(vhost_subsite_url) [subsite::get_url]
+ return $ad_conn(vhost_subsite_url)
+ }
+ vhost_package_url {
+ set ad_conn(vhost_package_url) "[subsite::get_url][ad_conn node_name]"
+ return $ad_conn(vhost_package_url)
+ }
default {
return [ns_conn $var]
}
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 -N -r1.79 -r1.80
--- openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 27 Jan 2005 21:36:32 -0000 1.79
+++ openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 18 Feb 2005 19:08:53 -0000 1.80
@@ -2716,6 +2716,46 @@
}
}
+ad_proc -public util_driver_info {
+ {-array:required}
+ {-driver ""}
+} {
+ Returns the protocol and port for the specified driver.
+
+ @param driver the driver to query (defaults to [ad_conn driver])
+ @param array the array to populate with proto and port
+} {
+ upvar $array result
+
+ if {[string equal $driver ""]} {
+ set driver [ad_conn driver]
+ }
+
+ switch $driver {
+ nssock {
+ set result(proto) http
+ set result(port) [ns_config -int "ns/server/[ns_info server]/module/nssock" Port]
+ }
+ nsunix {
+ set result(proto) http
+ set result(port) {}
+ }
+ nsssl - nsssle {
+ set result(port) [ns_config -int "ns/server/[ns_info server]/module/[ad_conn driver]" Port]
+ set result(proto) https
+ }
+ nsopenssl {
+ set result(port) [ns_config -int "ns/server/[ns_info server]/module/[ad_conn driver]" ServerPort]
+ set result(proto) https
+ }
+ default {
+ ns_log Error "Unknown driver: [ad_conn driver]. Only know nssock, nsunix, nsssl, nsssle, nsopenssl"
+ set result(port) [ns_config -int "ns/server/[ns_info server]/module/nssock" Port]
+ set result(proto) http
+ }
+ }
+}
+
ad_proc -public util_current_location {{}} {
Like ad_conn location - Returns the location string of the current
request in the form protocol://hostname[:port] but it looks at the
@@ -2736,29 +2776,9 @@
set default_port(http) 80
set default_port(https) 443
- switch [ad_conn driver] {
- nssock {
- set proto http
- set port [ns_config -int "ns/server/[ns_info server]/module/nssock" Port]
- }
- nsunix {
- set proto http
- set port {}
- }
- nsssl - nsssle {
- set port [ns_config -int "ns/server/[ns_info server]/module/[ad_conn driver]" Port]
- set proto https
- }
- nsopenssl {
- set port [ns_config -int "ns/server/[ns_info server]/module/[ad_conn driver]" ServerPort]
- set proto https
- }
- default {
- ns_log Error "Unknown driver: [ad_conn driver]. Only know nssock, nsunix, nsssl, nsssle, nsopenssl"
- set port [ns_config -int "ns/server/[ns_info server]/module/nssock" Port]
- set proto http
- }
- }
+ util_driver_info -array driver
+ set proto $driver(proto)
+ set port $driver(port)
# This is the host from the browser's HTTP request
set Host [ns_set iget [ad_conn headers] Host]