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. 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 proc Indirect_Url {virtual directory {prefix {}} {inThread 0}} { global 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 IndirectDomain $prefix $directory] $inThread } proc Direct_UrlRemove {prefix} { global Indirect catch { Url_PrefixRemove $Indirect($prefix) } catch { unset Indirect($prefix) } } proc IndirectDomain {prefix directory sock suffix} { global 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 proc /indirect/moop {args} { return "<html><head><title>Moop</title></head><body>$args</body></html>" } proc /indirect/* {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>" }