From: Vince Darley Date: Wed, 29 Aug 2001 14:49:32 +0000 (+0000) Subject: urltypes work X-Git-Tag: vfs-1-2~121 X-Git-Url: http://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=437b3113b1e752bf50eed34b7869b4f5ffacd11a;p=tclvfs urltypes work --- diff --git a/library/ftpvfs.tcl b/library/ftpvfs.tcl index eda3f7d..1d6104d 100644 --- a/library/ftpvfs.tcl +++ b/library/ftpvfs.tcl @@ -5,18 +5,20 @@ package require ftp namespace eval vfs::ftp {} proc vfs::ftp::Mount {dirurl local} { + ::vfs::log "ftp-vfs: attempt to mount $dirurl at $local" if {[string range $dirurl 0 5] == "ftp://"} { set dirurl [string range $dirurl 6 end] } - if {![regexp {(([^:]*)(:([^@]*))?@)?([^/]*)/(.*/)?([^/]*)$} $dirurl \ - junk junk user junk pass host path file]} { + if {![regexp {(([^:]*)(:([^@]*))?@)?([^/]*)(/(.*/)?([^/]*))?$} $dirurl \ + junk junk user junk pass host "" path file]} { return -code error "Sorry I didn't understand\ the url address \"$dirurl\"" } if {[string length $file]} { return -code error "Can only mount directories, not\ - files (perhaps you need a trailing '/')" + files (perhaps you need a trailing '/' - I understood\ + a path '$path' and file '$file')" } if {![string length $user]} { @@ -27,11 +29,13 @@ proc vfs::ftp::Mount {dirurl local} { if {$fd == -1} { error "Mount failed" } - if {[catch { - ::ftp::Cd $fd $path - } err]} { - ftp::Close $fd - error "Opened ftp connection, but then received error: $err" + if {$path != ""} { + if {[catch { + ::ftp::Cd $fd $path + } err]} { + ftp::Close $fd + error "Opened ftp connection, but then received error: $err" + } } ::vfs::log "ftp $host, $path mounted at $fd" @@ -82,7 +86,7 @@ proc vfs::ftp::stat {fd name} { } proc vfs::ftp::access {fd name mode} { - ::vfs::log "access $name $mode" + ::vfs::log "ftp-access $name $mode" if {$name == ""} { return 1 } set info [vfs::ftp::_findFtpInfo $fd $name] if {[string length $info]} { diff --git a/library/tclIndex b/library/tclIndex index 60f8b56..fc27b0a 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -90,6 +90,7 @@ set auto_index(::vfs::debug) [list source [file join $dir vfs.tcl]] set auto_index(::vfs::urltype::Mount) [list source [file join $dir vfsUrl.tcl]] set auto_index(::vfs::urltype::handler) [list source [file join $dir vfsUrl.tcl]] set auto_index(::vfs::urltype::stat) [list source [file join $dir vfsUrl.tcl]] +set auto_index(::vfs::urltype::open) [list source [file join $dir vfsUrl.tcl]] set auto_index(::vfs::urltype::access) [list source [file join $dir vfsUrl.tcl]] set auto_index(::vfs::urltype::matchindirectory) [list source [file join $dir vfsUrl.tcl]] set auto_index(::vfs::urltype::createdirectory) [list source [file join $dir vfsUrl.tcl]] diff --git a/library/vfsUrl.tcl b/library/vfsUrl.tcl index 18a8303..70dbba1 100644 --- a/library/vfsUrl.tcl +++ b/library/vfsUrl.tcl @@ -28,66 +28,87 @@ proc vfs::urltype::Mount {type} { } proc vfs::urltype::handler {type cmd root relative actualpath args} { - puts stderr [list $type $cmd $root $relative $actualpath $args] + puts stderr [list urltype $type $cmd $root $relative $actualpath $args] if {$cmd == "matchindirectory"} { - eval [list $cmd $type $relative $actualpath] $args + eval [list $cmd $type $root $relative $actualpath] $args } else { - eval [list $cmd $type $relative] $args + eval [list $cmd $type $root $relative] $args } } # Stuff below not very well implemented. -proc vfs::urltype::stat {ns name} { +proc vfs::urltype::stat {type root name} { ::vfs::log "stat $name" if {![string length $name]} { return [list type directory size 0 mode 0777 \ ino -1 depth 0 name $name atime 0 ctime 0 mtime 0 dev -1 \ uid -1 gid -1 nlink 1] } elseif {1} { + ::vfs::${type}::Mount $name [file join $root $name] return [list type file] } else { return -code error "could not read \"$name\": no such file or directory" } } -proc vfs::urltype::access {ns name mode} { +proc vfs::urltype::open {type root name mode permissions} { + ::vfs::log "open $name $mode $permissions" + # There are no 'files' and everything is read-only + return -code error "illegal access mode \"$mode\"" +} + +proc vfs::urltype::access {type root name mode} { ::vfs::log "access $name $mode" if {![string length $name]} { return 1 - } elseif {1} { - if {$mode & 2} { - error "read-only" - } - return 1 + } elseif {$mode & 2} { + error "read-only" } else { - error "No such file" + ::vfs::${type}::Mount $name [file join $root $name] } } -proc vfs::urltype::matchindirectory {ns path actualpath pattern type} { - ::vfs::log "matchindirectory $path $actualpath $pattern $type" - set res [list] +proc vfs::urltype::matchindirectory {type root path actualpath pattern types} { + ::vfs::log [list matchindirectory $root $path $actualpath $pattern $types] + + if {![vfs::matchDirectories $types]} { return [list] } + set res [list] + set len [string length $root] + + foreach m [::vfs::filesystem info] { + if {[string equal [string range $m 0 [expr {$len -1}]] $root]} { + set rest [string range $m $len end] + if {[string length $rest]} { + if {[string match $pattern $rest]} { + lappend res "$m" + } + } + } + } return $res } -proc vfs::urltype::createdirectory {ns name} { +proc vfs::urltype::createdirectory {type root name} { ::vfs::log "createdirectory $name" + # For ftp/http/file types we don't want to allow anything here. error "" } -proc vfs::urltype::removedirectory {ns name} { +proc vfs::urltype::removedirectory {type root name} { ::vfs::log "removedirectory $name" + # For ftp/http/file types we don't want to allow anything here. error "" } -proc vfs::urltype::deletefile {ns name} { +proc vfs::urltype::deletefile {type root name} { ::vfs::log "deletefile $name" + # For ftp/http/file types we don't want to allow anything here. error "" } -proc vfs::urltype::fileattributes {fd path args} { +proc vfs::urltype::fileattributes {type root path args} { ::vfs::log "fileattributes $args" switch -- [llength $args] { 0 { @@ -106,7 +127,8 @@ proc vfs::urltype::fileattributes {fd path args} { } } -proc vfs::urltype::utime {what name actime mtime} { +proc vfs::urltype::utime {type root name actime mtime} { ::vfs::log "utime $name" + # For ftp/http/file types we don't want to allow anything here. error "" }