Improved library, ftp vfs works

diff --git a/library/ftpvfs.tcl b/library/ftpvfs.tcl
index 7dad36e7151cb46d05cdebf16b6c835ad1db172e..d0ba11a1239a1e6c66575d0a41f9e09afb1310ef 100644 (file)
--- a/library/ftpvfs.tcl
+++ b/library/ftpvfs.tcl
@@ -5,74 +5,208 @@ package require ftp
 namespace eval vfs::ftp {}
 
 proc vfs::ftp::Mount {dirurl local} {
+    if {[string range $dirurl 0 5] == "ftp://"} {
+       set dirurl [string range $dirurl 6 end]
+    }
     regexp {(([^:]*)(:([^@]*))?@)?([^/]*)/(.*/)?([^/]*)$} $dirurl \
       junk junk user junk pass host path file
     
+    if {[string length $file]} {
+       return -code error "Can only mount directories, not\
+         files (perhaps you need a trailing '/')"
+    }
+    
+    if {![string length $user]} {
+       set user anonymous
+    }
+    
     set fd [::ftp::Open $host $user $pass $path]
-    ::ftp::Cd $fd $path
-    puts "ftp $host, $path mounted at $fd"
+    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"
+    }
+    
+    ::vfs::log "ftp $host, $path mounted at $fd"
     vfs::filesystem mount $local [list vfs::ftp::handler $fd $path]
+    # Register command to unmount
+    vfs::RegisterMount $local [list ::vfs::ftp::Unmount $fd]
     return $fd
 }
 
-proc vfs::ftp::Unmount {fd} {
+proc vfs::ftp::Unmount {fd local} {
+    vfs::filesystem unmount $local
     ::ftp::Close $fd
 }
 
 proc vfs::ftp::handler {fd path cmd root relative actualpath args} {
-    eval [list $cmd $fd $path $relative] $args
+    if {$cmd == "matchindirectory"} {
+       eval [list $cmd $fd $relative $actualpath] $args
+    } else {
+       eval [list $cmd $fd $relative] $args
+    }
 }
 
 # If we implement the commands below, we will have a perfect
 # virtual file system for remote ftp sites.
 
-proc vfs::ftp::stat {fd path name} {
-    puts "stat $name"
+proc vfs::ftp::stat {fd name} {
+    ::vfs::log "stat $name"
+    if {$name == ""} {
+       return [list type directory mtime 0 size 0 mode 0777 ino -1 \
+         depth 0 name "" dev -1 uid -1 gid -1 nlink 1]
+    }
+    
+    # get information on the type of this file
+    set ftpInfo [_findFtpInfo $fd $name]
+    if {$ftpInfo == ""} { error "Couldn't find file info" }
+    ::vfs::log $ftpInfo
+    set perms [lindex $ftpInfo 0]
+    if {[string index $perms 0] == "d"} {
+       lappend res type directory
+       set mtime 0
+    } else {
+       lappend res type file
+       set mtime [ftp::ModTime $fd $name]
+    }
+    lappend res dev -1 uid -1 gid -1 nlink 1 depth 0 \
+      atime $mtime ctime $mtime mtime $mtime mode 0777
+    return $res
 }
 
-proc vfs::ftp::access {fd path name mode} {
-    puts "access $name $mode"
+proc vfs::ftp::access {fd name mode} {
+    ::vfs::log "access $name $mode"
+    if {$name == ""} { return 1 }
+    set info [vfs::ftp::_findFtpInfo $fd $name]
+    if {[string length $info]} {
+       return 1
+    } else {
+       error "No such file"
+    }
 }
 
+# We've chosen to implement these channels by using a memchan.
+# The alternative would be to use temporary files.
 proc vfs::ftp::open {fd name mode permissions} {
-    puts "open $name $mode $permissions"
+    ::vfs::log "open $name $mode $permissions"
     # 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
     #    the channel is closed.
-    return [list]
+    switch -glob -- $mode {
+       "" -
+       "r" {
+           ftp::Get $fd $name -variable tmp
+           package require Memchan
+
+           set filed [memchan]
+           fconfigure $filed -translation binary
+           puts -nonewline $filed $tmp
+
+           fconfigure $filed -translation auto
+           seek $filed 0
+           return [list $filed]
+       }
+       "a" {
+           # Try to append nothing to the file
+           if {[catch [list ::ftp::Append $fd -data "" $name] err] || !$err} {
+               error "Can't open $name for appending"
+           }
+           package require Memchan
+           set filed [memchan]
+           return [list $filed [list ::vfs::ftp::_closing $fd $name $filed Append]]
+       }
+       "w*" {
+           # Try to write an empty file
+           if {[catch [list ::ftp::Put $fd -data "" $name] err] || !$err} {
+               error "Can't open $name for writing"
+           }
+           package require Memchan
+           set filed [memchan]
+           return [list $filed [list ::vfs::ftp::_closing $fd $name $filed Put]]
+       }
+       default {
+           return -code error "illegal access mode \"$mode\""
+       }
+    }
+}
+
+proc vfs::ftp::_closing {fd name filed action} {
+    seek $filed 0
+    set contents [read $filed]
+    if {![::ftp::$action $fd -data $contents $name]} {
+       error "Failed to write to $name"
+    }
+}
+
+proc vfs::ftp::_findFtpInfo {fd name} {
+    ::vfs::log "findFtpInfo $fd $name"
+    set ftpList [ftp::List $fd [file dirname $name]]
+    foreach p $ftpList {
+       regsub -all "\[ \t\]+" $p " " p
+       set items [split $p " "]
+       set pname [lindex $items end]
+       if {$pname == [file tail $name]} {
+           return $items
+       }
+    }
+    return ""
 }
 
-proc vfs::ftp::matchindirectory {fd prefix path pattern type} {
-    puts "matchindirectory $path $pattern $type"
+proc vfs::ftp::matchindirectory {fd path actualpath pattern type} {
+    ::vfs::log "matchindirectory $path $pattern $type"
     set ftpList [ftp::List $fd $path]
-    puts "ftpList: $ftpList"
+    ::vfs::log "ftpList: $ftpList"
     set res [list]
 
-    if {[::vfs::matchDirectories $type]} {
-       # add matching directories to $res
-    }
-    
-    if {[::vfs::matchFiles $type]} {
-       # add matching files to $res
+    foreach p $ftpList {
+       regsub -all "\[ \t\]+" $p " " p
+       set items [split $p " "]
+       set name [lindex $items end]
+       set perms [lindex $items 0]
+       if {[::vfs::matchDirectories $type]} {
+           if {[string index $perms 0] == "d"} {
+               lappend res "$actualpath$name"
+           }
+       }
+       if {[::vfs::matchFiles $type]} {
+           if {[string index $perms 0] != "d"} {
+               lappend res "$actualpath$name"
+           }
+       }
+       
     }
+ 
     return $res
 }
 
 proc vfs::ftp::createdirectory {fd name} {
-    puts "createdirectory $name"
+    ::vfs::log "createdirectory $name"
+    if {![ftp::MkDir $fd $name]} {
+       error "failed"
+    }
 }
 
 proc vfs::ftp::removedirectory {fd name} {
-    puts "removedirectory $name"
+    ::vfs::log "removedirectory $name"
+    if {![ftp::RmDir $fd $name]} {
+       error "failed"
+    }
 }
 
 proc vfs::ftp::deletefile {fd name} {
-    puts "deletefile $name"
+    ::vfs::log "deletefile $name"
+    if {![ftp::Delete $fd $name]} {
+       error "failed"
+    }
 }
 
 proc vfs::ftp::fileattributes {fd path args} {
-    puts "fileattributes $args"
+    ::vfs::log "fileattributes $args"
     switch -- [llength $args] {
        0 {
            # list strings
@@ -91,6 +225,6 @@ proc vfs::ftp::fileattributes {fd path args} {
 }
 
 proc vfs::ftp::utime {fd path actime mtime} {
-    
+    error "Can't set utime"
 }
 

diff --git a/library/mk4vfs.tcl b/library/mk4vfs.tcl
index 340c448620c0343ece3fb4e588ea67bab23e5a30..3ff9f1dce9baf4b0ccf32bef381c58b7f381bd57 100644 (file)
--- a/library/mk4vfs.tcl
+++ b/library/mk4vfs.tcl
@@ -104,8 +104,17 @@
 namespace eval vfs::mk4 {}
 
 proc vfs::mk4::Mount {what local args} {
-    set fd [eval [list ::mk4vfs::mount $what $local] $args]
-    return $fd
+    set dd [eval [list ::mk4vfs::mount $what $local] $args]
+
+    ::vfs::filesystem mount $path [list ::vfs::mk4::handler $db]
+    # Register command to unmount
+    vfs::RegisterMount $local [list ::vfs::mk4::Unmount $db]
+    return $dd
+}
+
+proc vfs::mk4::Unmount {db local} {
+    vfs::filesystem unmount $local
+    ::mk4tcl::umount $db
 }
 
 proc vfs::mk4::handler {db cmd root relative actualpath args} {
@@ -355,8 +364,6 @@ proc mk4vfs::mount {path file args} {
 
     init $db
 
-    ::vfs::filesystem mount $path [list ::vfs::mk4::handler $db]
-
     set flush 1
     for {set idx 0} {$idx < [llength $args]} {incr idx} {
         switch -- [lindex $args $idx] {
@@ -375,9 +382,9 @@ proc mk4vfs::_commit {db} {
     mk::file commit $db
 }
 
-proc mk4vfs::umount {path args} {
-    tclLog [list unmount $path $args]
-    return [eval [list vfs::filesystem unmount $path] $args]
+proc mk4vfs::umount {db} {
+    tclLog [list unmount $db]
+    mk::file close $db
 }
 
 proc mk4vfs::stat {db path arr} {

diff --git a/library/tclIndex b/library/tclIndex
index 3d43b66b4dc17c0eb2fd81224b01d868e987a421..73659eaadb84579889c75e3f327f48bdfc83d8cc 100644 (file)
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -12,11 +12,41 @@ set auto_index(::vfs::ftp::handler) [list source [file join $dir ftpvfs.tcl]]
 set auto_index(::vfs::ftp::stat) [list source [file join $dir ftpvfs.tcl]]
 set auto_index(::vfs::ftp::access) [list source [file join $dir ftpvfs.tcl]]
 set auto_index(::vfs::ftp::open) [list source [file join $dir ftpvfs.tcl]]
+set auto_index(::vfs::ftp::_closing) [list source [file join $dir ftpvfs.tcl]]
+set auto_index(::vfs::ftp::_findFtpInfo) [list source [file join $dir ftpvfs.tcl]]
 set auto_index(::vfs::ftp::matchindirectory) [list source [file join $dir ftpvfs.tcl]]
 set auto_index(::vfs::ftp::createdirectory) [list source [file join $dir ftpvfs.tcl]]
 set auto_index(::vfs::ftp::removedirectory) [list source [file join $dir ftpvfs.tcl]]
 set auto_index(::vfs::ftp::deletefile) [list source [file join $dir ftpvfs.tcl]]
 set auto_index(::vfs::ftp::fileattributes) [list source [file join $dir ftpvfs.tcl]]
+set auto_index(::vfs::ftp::utime) [list source [file join $dir ftpvfs.tcl]]
+set auto_index(::vfs::mk4::Mount) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::Unmount) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::handler) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::utime) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::matchindirectory) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::stat) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::access) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::open) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::createdirectory) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::removedirectory) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::deletefile) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::vfs::mk4::fileattributes) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::init) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::mount) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::_commit) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::umount) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::stat) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::driver) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::do_close) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::mkdir) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::getdir) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::mtime) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::delete) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::find/file) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::mk4vfs::find/dir) [list source [file join $dir mk4vfs.tcl]]
+set auto_index(::scripdoc::init) [list source [file join $dir scripdoc.tcl]]
+set auto_index(::scripdoc::extendPath) [list source [file join $dir scripdoc.tcl]]
 set auto_index(::vfs::tclproc::Mount) [list source [file join $dir tclprocvfs.tcl]]
 set auto_index(::vfs::tclproc::Unmount) [list source [file join $dir tclprocvfs.tcl]]
 set auto_index(::vfs::tclproc::handler) [list source [file join $dir tclprocvfs.tcl]]
@@ -30,7 +60,9 @@ set auto_index(::vfs::tclproc::createdirectory) [list source [file join $dir tcl
 set auto_index(::vfs::tclproc::removedirectory) [list source [file join $dir tclprocvfs.tcl]]
 set auto_index(::vfs::tclproc::deletefile) [list source [file join $dir tclprocvfs.tcl]]
 set auto_index(::vfs::tclproc::fileattributes) [list source [file join $dir tclprocvfs.tcl]]
-set auto_index(::vfs::testMount) [list source [file join $dir testvfs.tcl]]
+set auto_index(::vfs::tclproc::utime) [list source [file join $dir tclprocvfs.tcl]]
+set auto_index(::vfs::test::Mount) [list source [file join $dir testvfs.tcl]]
+set auto_index(::vfs::test::Unmount) [list source [file join $dir testvfs.tcl]]
 set auto_index(::vfs::test::handler) [list source [file join $dir testvfs.tcl]]
 set auto_index(::vfs::test::stat) [list source [file join $dir testvfs.tcl]]
 set auto_index(::vfs::test::access) [list source [file join $dir testvfs.tcl]]
@@ -40,8 +72,14 @@ set auto_index(::vfs::test::createdirectory) [list source [file join $dir testvf
 set auto_index(::vfs::test::removedirectory) [list source [file join $dir testvfs.tcl]]
 set auto_index(::vfs::test::deletefile) [list source [file join $dir testvfs.tcl]]
 set auto_index(::vfs::test::fileattributes) [list source [file join $dir testvfs.tcl]]
+set auto_index(::vfs::test::utime) [list source [file join $dir testvfs.tcl]]
+set auto_index(::vfs::debug) [list source [file join $dir vfs.tcl]]
+set auto_index(::vfs::log) [list source [file join $dir vfs.tcl]]
 set auto_index(::vfs::autoMountExtension) [list source [file join $dir vfsUtils.tcl]]
 set auto_index(::vfs::autoMountUrl) [list source [file join $dir vfsUtils.tcl]]
+set auto_index(::vfs::log) [list source [file join $dir vfsUtils.tcl]]
+set auto_index(::vfs::RegisterMount) [list source [file join $dir vfsUtils.tcl]]
+set auto_index(::vfs::unmount) [list source [file join $dir vfsUtils.tcl]]
 set auto_index(::vfs::haveMount) [list source [file join $dir vfsUtils.tcl]]
 set auto_index(::vfs::urlMount) [list source [file join $dir vfsUtils.tcl]]
 set auto_index(::vfs::fileUrlMount) [list source [file join $dir vfsUtils.tcl]]
@@ -52,7 +90,12 @@ set auto_index(::vfs::accessMode) [list source [file join $dir vfsUtils.tcl]]
 set auto_index(::vfs::matchDirectories) [list source [file join $dir vfsUtils.tcl]]
 set auto_index(::vfs::matchFiles) [list source [file join $dir vfsUtils.tcl]]
 set auto_index(::vfs::modeToString) [list source [file join $dir vfsUtils.tcl]]
+set auto_index(::vfs::listAttributes) [list source [file join $dir vfsUtils.tcl]]
+set auto_index(::vfs::indexToAttribute) [list source [file join $dir vfsUtils.tcl]]
+set auto_index(::vfs::attributesGet) [list source [file join $dir vfsUtils.tcl]]
+set auto_index(::vfs::attributesSet) [list source [file join $dir vfsUtils.tcl]]
 set auto_index(::vfs::posixError) [list source [file join $dir vfsUtils.tcl]]
+set auto_index(::vfs::zip::Execute) [list source [file join $dir zipvfs.tcl]]
 set auto_index(::vfs::zip::Mount) [list source [file join $dir zipvfs.tcl]]
 set auto_index(::vfs::zip::Unmount) [list source [file join $dir zipvfs.tcl]]
 set auto_index(::vfs::zip::handler) [list source [file join $dir zipvfs.tcl]]
@@ -64,6 +107,7 @@ set auto_index(::vfs::zip::createdirectory) [list source [file join $dir zipvfs.
 set auto_index(::vfs::zip::removedirectory) [list source [file join $dir zipvfs.tcl]]
 set auto_index(::vfs::zip::deletefile) [list source [file join $dir zipvfs.tcl]]
 set auto_index(::vfs::zip::fileattributes) [list source [file join $dir zipvfs.tcl]]
+set auto_index(::vfs::zip::utime) [list source [file join $dir zipvfs.tcl]]
 set auto_index(::zip::u_short) [list source [file join $dir zipvfs.tcl]]
 set auto_index(::zip::DosTime) [list source [file join $dir zipvfs.tcl]]
 set auto_index(::zip::Data) [list source [file join $dir zipvfs.tcl]]

diff --git a/library/tclprocvfs.tcl b/library/tclprocvfs.tcl
index 953cdd184a12deec4d7273baf5f15ac89d73b6de..abc8a7066909e4a20da17ff82412a3018c551a9c 100644 (file)
--- a/library/tclprocvfs.tcl
+++ b/library/tclprocvfs.tcl
@@ -15,9 +15,11 @@ proc vfs::tclproc::Mount {ns local} {
     }
     puts "tclproc $ns mounted at $local"
     vfs::filesystem mount $local [list vfs::tclproc::handler $ns]
+    vfs::RegisterMount $local [list vfs::tclproc::handler]
 }
 
-proc vfs::tclproc::Unmount {ns} {
+proc vfs::tclproc::Unmount {local} {
+    vfs::filesystem unmount $local
 }
 
 proc vfs::tclproc::handler {ns cmd root relative actualpath args} {

diff --git a/library/testvfs.tcl b/library/testvfs.tcl
index 2b6db90379bfa1557f2461dacc3aa2891c16f166..adf13c79ee2cfa25d6364b4cfc08739e9e010d8f 100644 (file)
--- a/library/testvfs.tcl
+++ b/library/testvfs.tcl
@@ -1,11 +1,16 @@
 
 package require vfs 1.0
 
-proc vfs::testMount {what local} {
-    vfs::filesystem mount $local [list vfs::test::handler $what]
+namespace eval vfs::test {}
+
+proc vfs::test::Mount {what local} {
+    vfs::filesystem mount $local [list ::vfs::test::handler $what]
+    vfs::RegisterMount $local [list ::vfs::test::Unmount]
 }
 
-namespace eval vfs::test {}
+proc vfs::test::Unmount {local} {
+    vfs::filesystem unmount $local
+}
 
 proc vfs::test::handler {what cmd root relative actualpath args} {
     eval [list $cmd $what $relative] $args

diff --git a/library/vfsUtils.tcl b/library/vfsUtils.tcl
index 29dc811d5b69e0a6877f3897e6c7e1919b3fc63a..0895e8187c4ad4975f05e6a6568c1a98ba624177 100644 (file)
--- a/library/vfsUtils.tcl
+++ b/library/vfsUtils.tcl
@@ -11,6 +11,21 @@ proc ::vfs::autoMountUrl {type cmd {pkg ""}} {
     set urlMounts($type) [list $cmd $pkg]
 }
 
+proc ::vfs::log {str} {
+    puts stderr $str
+}
+
+proc ::vfs::RegisterMount {mountpoint unmountcmd} {
+    variable _unmountCmd
+    set _unmountCmd([file normalize $mountpoint]) $unmountcmd
+}
+
+proc ::vfs::unmount {mountpoint} {
+    variable _unmountCmd
+    set norm [file normalize $mountpoint]
+    uplevel \#0 $_unmountCmd($norm) [list $norm]
+}
+
 ::vfs::autoMountExtension .zip ::vfs::zip::Mount vfs
 ::vfs::autoMountUrl ftp ::vfs::ftp::Mount vfs
 ::vfs::autoMountUrl file ::vfs::fileUrlMount vfs

diff --git a/library/zipvfs.tcl b/library/zipvfs.tcl
index c64f96a96b27dcc21328f1cafbeb7faa76477e0e..bc7a1d0417fbe62b34479f1848d1014f1a55a82e 100644 (file)
--- a/library/zipvfs.tcl
+++ b/library/zipvfs.tcl
@@ -6,13 +6,24 @@ package require vfs 1.0
 
 namespace eval vfs::zip {}
 
+# Used to execute a zip archive.  This is rather like a jar file
+# but simpler.  We simply mount it and then source a toplevel
+# file called 'main.tcl'.
+proc vfs::zip::Execute {zipfile} {
+    Mount $zipfile $zipfile
+    source [file join $zipfile main.tcl]
+}
+
 proc vfs::zip::Mount {zipfile local} {
     set fd [::zip::open [::file normalize $zipfile]]
     vfs::filesystem mount $local [list ::vfs::zip::handler $fd]
+    # Register command to unmount
+    vfs::RegisterMount $local [list ::vfs::zip::Unmount $fd]
     return $fd
 }
 
 proc vfs::zip::Unmount {fd} {
+    vfs::filesystem unmount $local
     ::zip::_close $fd
 }