This is a fusion of tclhttpd Direct and Doc domains
It will try to find a match using the same technique as Doc, and fall back to a Direct domain if it can't. Additionally, the ${prefix}/* proc will be called on no match.
You will need tclhttpd version 3.5.1 at least, but newer is always better.
Enjoy! -- CMcC 20041120
To create an Indirect domain you call [Indirect::Url virtual directory prefix] where virtual is the URL path to this domain, directory is the file directory for templates and prefix is a prefix to be added to the command invocation.
This domain would be useful for applications which operate on directories and files - one could, for example, create a [search] process which searched the files in a directory, one could use the * function to create new files on demand, as in Wikit.
package require httpd::direct
namespace eval Indirect {
variable Indirect
}
proc Indirect::Url {virtual directory {prefix {}} {inThread 0}} {
variable Indirect
if {[string length $prefix] == 0} {
set prefix $virtual
}
set Indirect($prefix) $virtual ;# So we can reconstruct URLs
Doc_RegisterRoot $virtual $directory
Url_PrefixInstall $virtual [list Indirect::domain $prefix $directory] $inThread
}
proc Indirect::UrlRemove {prefix} {
variable Indirect
catch { Url_PrefixRemove $Indirect($prefix) }
catch { unset Indirect($prefix) }
}
proc Indirect::domain {prefix directory sock suffix} {
variable Indirect
upvar #0 Httpd$sock data
# Prepare argument data from the query data.
Url_QuerySetup $sock
set path [file join $directory [string trimleft $suffix /~]]
set path [file normalize $path]
set data(path) $path ;# record this path for not found handling
set data(directory) $directory
# Look for a fresh template which generates the desired path
if {[Template_Try $sock $path $prefix $suffix]} {
# template has handled the request
return 1
}
# Template_Try hasn't satisfied the request,
# Look for an exact match.
if {[file exists $path] && [file readable $path]} {
# we have a file precisely matching the request
Doc_Return $prefix $path $suffix $sock
return 1
}
# no matching file - try a direct call
set cmd [Direct_MarshallArguments $prefix $suffix]
if {$cmd == ""} {
# Negotiate an Acceptable available alternative file
# if one is found, a redirect is provoked
# (FIXME: is this according to the spec?)
if {[Fallback_Try $prefix $path $suffix $sock]} {
# we have found an Accept-able alternative
# Fallback_Try generates a redirect
return 1
}
# still no match - try the * command
set cmd [Direct_MarshallArguments $prefix /*]
if {$cmd == ""} {
Doc_NotFound $sock
}
}
# Eval the command. Errors can be used to trigger redirects.
set code [catch $cmd result]
set type text/html
upvar #0 $prefix$suffix aType
if {[info exist aType]} {
set type $aType
}
Direct_Respond $sock $code $result $type
}Example indirect domain
Indirect::Url /indirect indirect_test ::indirect::
namespace eval indirect {
proc /moop {args} {
return "<html><head><title>Moop</title></head><body>$args</body></html>"
}
proc /* {args} {
upvar #0 Httpd[Httpd_CurrentSocket] data
return "<html><head><title>Moop</title></head><body><h3>Not Found</h3><p>[array get data]</p></body></html>"
}
}