better url support

diff --git a/library/ftpvfs.tcl b/library/ftpvfs.tcl
index f4730df529607082f2dad1229a12e58a68ec8e4e..67faec7fc52aa0bf0581b65627adb8578b64ae61 100644 (file)
--- a/library/ftpvfs.tcl
+++ b/library/ftpvfs.tcl
@@ -6,11 +6,13 @@ 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 {[string index $dirurl end] != "/"} {
+       ::vfs::log "ftp-vfs: adding missing directory delimiter to mount point"
+       append dirurl "/"
     }
-    if {![regexp {(([^:]*)(:([^@]*))?@)?([^/]*)(/(.*/)?([^/]*))?$} $dirurl \
-      junk junk user junk pass host "" path file]} {
+    
+    if {![regexp {(ftp://)?(([^:]*)(:([^@]*))?@)?([^/]*)(/(.*/)?([^/]*))?$} \
+      $dirurl junk junk junk user junk pass host "" path file]} {
        return -code error "Sorry I didn't understand\
          the url address \"$dirurl\""
     }
@@ -38,6 +40,11 @@ proc vfs::ftp::Mount {dirurl local} {
        }
     }
     
+    if {![catch {vfs::filesystem info $dirurl}]} {
+       # unmount old mount
+       ::vfs::log "ftp-vfs: unmounted old mount point at $dirurl"
+       vfs::unmount $dirurl
+    }
     ::vfs::log "ftp $host, $path mounted at $fd"
     vfs::filesystem mount $local [list vfs::ftp::handler $fd $path]
     # Register command to unmount

diff --git a/library/httpvfs.tcl b/library/httpvfs.tcl
index f2869a8a4ab74af5917855b5cb5daef0005e7228..de2afbc7e931e446ffe9efb757b6c51a94c35b0a 100644 (file)
--- a/library/httpvfs.tcl
+++ b/library/httpvfs.tcl
@@ -36,6 +36,11 @@ proc vfs::http::Mount {dirurl local} {
     
     set token [::http::geturl $dirurl -validate 1]
 
+    if {![catch {vfs::filesystem info $dirurl}]} {
+       # unmount old mount
+       ::vfs::log "ftp-vfs: unmounted old mount point at $dirurl"
+       vfs::unmount $dirurl
+    }
     ::vfs::log "http $host, $path mounted at $local"
     vfs::filesystem mount $local [list vfs::http::handler $dirurl $path]
     # Register command to unmount

diff --git a/library/vfsUrl.tcl b/library/vfsUrl.tcl
index 5035e2e89735c5c35155a9b3c809b8b68329b886..c1c284c582a0584e58db5796193376b5cb9def71 100644 (file)
--- a/library/vfsUrl.tcl
+++ b/library/vfsUrl.tcl
@@ -17,14 +17,24 @@
 namespace eval ::vfs::urltype {}
 
 proc vfs::urltype::Mount {type} {
-    # This requires Tcl 8.4a4.
+    set mountPoint [_typeToMount $type]
+    ::vfs::addVolume $mountPoint
+    ::vfs::filesystem mount $mountPoint [list vfs::urltype::handler $type]
+    return "Mounted at \"${mountPoint}\""
+}
+
+proc vfs::urltype::Unmount {type} {
+    set mountPoint [_typeToMount $type]
+    ::vfs::filesystem unmount $mountPoint
+    ::vfs::removeVolume $mountPoint
+}
+
+proc vfs::urltype::_typeToMount {type} {
     set mountPoint "${type}://"
     if {$type == "file"} {
        append mountPoint "/"
     }
-    ::vfs::addVolume "${mountPoint}"
-    ::vfs::filesystem mount $mountPoint [list vfs::urltype::handler $type]
-    return "Mounted at \"${mountPoint}\""
+    return $mountPoint
 }
 
 proc vfs::urltype::handler {type cmd root relative actualpath args} {