From: Jeff Hobbs Date: Fri, 15 Sep 2006 20:00:32 +0000 (+0000) Subject: * library/pkgIndex.tcl: bump vfs::http to 0.6 X-Git-Tag: vfs-1-4~53 X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=6379c493ebdb2639c0ca6f058571f974c3cc9a72;p=tclvfs * library/pkgIndex.tcl: bump vfs::http to 0.6 * library/httpvfs.tcl: Add urlname encoding to handle the translation of "/foo/my file (2).txt" as foo/my%20file%20%282%29.txt, per RFC 3986, for the user. This is controlled via a new ?-urlencode bool? mount option, default 1. **** POTENTIAL INCOMPATIBILITY **** **** if user was "working around" at [open] level **** --- diff --git a/ChangeLog b/ChangeLog index eeb3e55..cbd3ad4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2006-09-15 Jeff Hobbs + + * library/pkgIndex.tcl: bump vfs::http to 0.6 + * library/httpvfs.tcl: Add urlname encoding to handle the + translation of "/foo/my file (2).txt" as + foo/my%20file%20%282%29.txt, per RFC 3986, for the user. This is + controlled via a new ?-urlencode bool? mount option, default 1. + **** POTENTIAL INCOMPATIBILITY **** + **** if user was "working around" at [open] level **** + 2006-09-14 Jeff Hobbs * library/httpvfs.tcl: rewritten to clean up http tokens and diff --git a/library/httpvfs.tcl b/library/httpvfs.tcl index 1b54032..3717ec3 100644 --- a/library/httpvfs.tcl +++ b/library/httpvfs.tcl @@ -1,15 +1,35 @@ -package provide vfs::http 0.5 +package provide vfs::http 0.6 package require vfs 1.0 package require http # This works for basic operations, but has not been very debugged. -namespace eval vfs::http {} +namespace eval vfs::http { + # Allow for options when mounting an http URL + variable options + # -urlencode means automatically parse "foo/my file (2).txt" as + # "foo/my%20file%20%282%29.txt", as per RFC 3986, for the user. + set options(-urlencode) 1 + # -urlparse would further parse URLs for ? (query string) and # (anchor) + # components, leaving those unencoded. Only works when -urlencode is true. + set options(-urlparse) 0 +} -proc vfs::http::Mount {dirurl local} { - ::vfs::log "http-vfs: attempt to mount $dirurl at $local" +proc vfs::http::Mount {dirurl local args} { + ::vfs::log "http-vfs: attempt to mount $dirurl at $local (args: $args)" + variable options + foreach {key val} $args { + # only do exact option name matching for now + if {[info exists options($key)]} { + # currently only boolean values + if {![string is boolean -strict $val]} { + return -code error "invalid boolean value \"$val\" for $key" + } + set options($key) $val + } + } if {[string index $dirurl end] ne "/"} { append dirurl "/" } @@ -68,16 +88,43 @@ proc vfs::http::handler {dirurl path cmd root relative actualpath args} { } } +proc vfs::http::urlname {name} { + # Parse the passed in name into a suitable URL name based on mount opts + variable options + if {$options(-urlencode)} { + set querystr "" + if {$options(-urlparse)} { + # check for ? and split if necessary so that the query_string + # part doesn't get encoded. Anchors come after this as well. + set idx [string first ? $name] + if {$idx >= 0} { + set querystr [string range $name $idx end] ; # includes ? + set name [string range $name 0 [expr {$idx-1}]] + } + } + set urlparts [list] + foreach part [file split $name] { + lappend urlparts [http::mapReply $part] + } + set urlname "[join $urlparts /]$querystr" + } else { + set urlname $name + } + return $urlname +} + # If we implement the commands below, we will have a perfect # virtual file system for remote http sites. proc vfs::http::stat {dirurl name} { - ::vfs::log "stat $name" + set urlname [urlname $name] + ::vfs::log "stat $name ($urlname)" # get information on the type of this file. We describe everything # as a file (not a directory) since with http, even directories # really behave as the index.html they contain. - set token [::http::geturl "$dirurl$name" -validate 1] + + set token [::http::geturl "$dirurl$urlname" -validate 1] http::wait $token set ncode [http::ncode $token] if {$ncode == 404 || [http::status $token] ne "ok"} { @@ -97,13 +144,14 @@ proc vfs::http::stat {dirurl name} { } proc vfs::http::access {dirurl name mode} { - ::vfs::log "access $name $mode" + set urlname [urlname $name] + ::vfs::log "access $name $mode ($urlname)" if {$mode & 2} { vfs::filesystem posixerror $::vfs::posix(EROFS) return -code error "read-only" } if {$name == ""} { return 1 } - set token [::http::geturl "$dirurl$name" -validate 1] + set token [::http::geturl "$dirurl$urlname" -validate 1] http::wait $token set ncode [http::ncode $token] if {$ncode == 404 || [http::status $token] ne "ok"} { @@ -122,7 +170,8 @@ proc vfs::http::access {dirurl name mode} { # We've chosen to implement these channels by using a memchan. # The alternative would be to use temporary files. proc vfs::http::open {dirurl name mode permissions} { - ::vfs::log "open $name $mode $permissions" + set urlname [urlname $name] + ::vfs::log "open $name $mode $permissions ($urlname)" # return a list of two elements: # 1. first element is the Tcl channel name which has been opened # 2. second element (optional) is a command to evaluate when @@ -130,7 +179,7 @@ proc vfs::http::open {dirurl name mode permissions} { switch -glob -- $mode { "" - "r" { - set token [::http::geturl "$dirurl$name"] + set token [::http::geturl "$dirurl$urlname"] set filed [vfs::memchan] fconfigure $filed -translation binary @@ -140,6 +189,7 @@ proc vfs::http::open {dirurl name mode permissions} { fconfigure $filed -translation auto seek $filed 0 + # XXX: the close command should free vfs::memchan somehow?? return [list $filed] } "a" - diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl index a20fd46..4931949 100644 --- a/library/pkgIndex.tcl +++ b/library/pkgIndex.tcl @@ -54,7 +54,7 @@ package ifneeded zipvfs 1.0 [list source [file join $dir zipvfs.tcl]] # New package ifneeded vfs::ftp 1.0 [list source [file join $dir ftpvfs.tcl]] -package ifneeded vfs::http 0.5 [list source [file join $dir httpvfs.tcl]] +package ifneeded vfs::http 0.6 [list source [file join $dir httpvfs.tcl]] package ifneeded vfs::mk4 1.10 [list source [file join $dir mk4vfs.tcl]] package ifneeded vfs::mkcl 1.4 [list source [file join $dir mkclvfs.tcl]] package ifneeded vfs::ns 0.5 [list source [file join $dir tclprocvfs.tcl]]