DGP 4-Jul-2003: Haven't tested the patch below, but it is not needed. tclhttpd 3.4 already supports virtual hosting. See the file README.virthost in the tclhttpd distribution for instructions.
PT 4-Jul-2003: This patch enhances the tcl httpd server to support for virtual hosting. You can install a virtual host check using Url_VirtualHostInstall. This provides a hook procedure which is called with two additional arguments - the socket and the supplied host. The host parameter is provided from the HTTP Host header. If this procedure returns anything other than an empty string, this is prepended to the URL. This is done before the access and virtual domain checks.
Note that the connection data still contains the original URL, so error messages will not include the prefix (which is as expected for a virtual host).
As an example let's setup localhost with a virtual root. This means connecting to the server with the proper name will get the usual tclhttpd initial screen, while connecting to localhost will be retargetted to a /localhost subtree.
To do this place the following in custom/vhost.tcl
# Add a virtual host root to this server. Clients attempting to
# connect to localhost for this server are redirected to the
# /localhost subtree of our document root.
Url_VirtualHostInstall ::vhost::Check
namespace eval vhost {}
proc ::vhost::Check {sock host} {
set host [string tolower $host]
set host [lindex [split $host :] 0]
if {$host == "localhost"} {
return "/localhost"
}
return ""
}The patch follows:
--- url.tcl.orig Thu Oct 12 17:00:42 2000
+++ url.tcl Fri Jul 04 12:03:19 2003
@@ -51,6 +51,17 @@
CountName $url hit
if {[catch {
+ # Check for Virtual Hosting. Rewrites the Url based upon the
+ # Host header.
+ if {[info exists data(mime,host)]} {
+ foreach hook $Url(vhostHooks) {
+ set prefix [eval $hook [list $sock $data(mime,host)]]
+ if {$prefix != {}} {
+ set url $prefix$url
+ }
+ }
+ }
+
# INLINE VERSION OF Url_PrefixMatch
if {![regexp ^($Url(prefixset))(.*) $url x prefix suffix] ||
@@ -297,6 +308,36 @@
if {![info exist Url(accessHooks)]} {
set Url(accessHooks) {}
+}
+
+# Url_VirtualHostInstall
+#
+# Install an Virtual Hosting check hook.
+#
+# Arguments
+# proc This is a command prefix that is invoked with two additional
+# arguments to check permissions:
+# sock The handle on the connection
+# host The value of the HTTP Host header
+# The access hook should return:
+# "" Meaning this hook has nothing to do.
+# a prefix If the hook matches a VHOST then this is
+# a url string to prepend to the called URL.
+# eg: /vhost1
+#
+# Side Effects
+# Save the access control hook
+
+proc Url_VirtualHostInstall {proc} {
+ global Url
+ if {[lsearch $Url(vhostHooks) $proc] < 0} {
+ lappend Url(vhostHooks) $proc
+ }
+ return
+}
+
+if {![info exist Url(vhostHooks)]} {
+ set Url(vhostHooks) {}
}
# Url_PrefixInstallYou can check a vhost running like this here:
http://www.kroc.tk