From: Vince Darley <vincentdarley@sourceforge.net>
Date: Wed, 5 Sep 2001 16:33:02 +0000 (+0000)
Subject: better url support
X-Git-Tag: vfs-1-2~115
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=194679744a305484f961abf45710b540ef60b4ff;p=tclvfs

better url support
---

diff --git a/library/ftpvfs.tcl b/library/ftpvfs.tcl
index f4730df..67faec7 100644
--- 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 f2869a8..de2afbc 100644
--- 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 5035e2e..c1c284c 100644
--- 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} {