urltypes work

diff --git a/library/ftpvfs.tcl b/library/ftpvfs.tcl
index eda3f7d7466a51ec7e163763251bf7ca26ee7050..1d6104d331b76e1b30389c23c79a4a77a65e5252 100644 (file)
--- 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 60f8b56ab620edaedf0d0a89551a5e8c1c0b9233..fc27b0a3682f1e349021dcaed8b7cbaea0a5945a 100644 (file)
--- 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 18a8303809ffe3b162d9cbd9edbcde22f29c1cb4..70dbba13b4dae67ba953d8fb700cfb1bb11a8e56 100644 (file)
--- 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 ""
 }