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 today's CVS HEAD at least, but newer is always better. See tclhttpd for how to get tar and zip snapshots.
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 prepended 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.
prefix can be a simple string, an alias, a namespace prefix or an interp eval prefix.
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>"
}
}