From: Vince Darley <vincentdarley@sourceforge.net>
Date: Mon, 17 Feb 2003 11:55:18 +0000 (+0000)
Subject: filesystem configuration first cut
X-Git-Tag: vfs-1-3~55
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=1bc6fdbc7af7ba1113176e54577306a2247b9935;p=tclvfs

filesystem configuration first cut
---

diff --git a/ChangeLog b/ChangeLog
index 18930a0..57c3bc1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2003-02-17  Vince Darley <vincentdarley@sourceforge.net>
+
+	* library/vfsUtils.tcl: added beginnings of interface for
+	filesystem configuration.
+	
 2003-02-01  Jean-Claude Wippler  <jcw@equi4.com>
 
 	* library/vfslib.tcl: fixed bug in new vfs::zstream code,
diff --git a/library/mk4vfs.tcl b/library/mk4vfs.tcl
index e78dbc4..05be7d7 100644
--- a/library/mk4vfs.tcl
+++ b/library/mk4vfs.tcl
@@ -56,7 +56,10 @@ namespace eval vfs::mk4 {
 	::mk4vfs::_umount $db
     }
 
-
+    proc state {} {
+	return "translucent"
+    }
+    
     proc handler {db cmd root relative actualpath args} {
 	#puts stderr "handler: $db - $cmd - $root - $relative - $actualpath - $args"
 	if {$cmd == "matchindirectory"} {
diff --git a/library/tclIndex b/library/tclIndex
index 2cf833e..6d19daf 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -35,6 +35,7 @@ set auto_index(::vfs::http::fileattributes) [list source [file join $dir httpvfs
 set auto_index(::vfs::http::utime) [list source [file join $dir httpvfs.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::state) [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]]
@@ -131,6 +132,7 @@ 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::attributes) [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]]
diff --git a/library/vfsUtils.tcl b/library/vfsUtils.tcl
index 881ba9b..330f687 100644
--- a/library/vfsUtils.tcl
+++ b/library/vfsUtils.tcl
@@ -59,6 +59,73 @@ proc ::vfs::unmount {mountpoint} {
     unset _unmountCmd($norm)
 }
 
+# vfs::attributes mountpoint ?-opt val? ?...-opt val?
+proc ::vfs::attributes {mountpoint args} {
+    if {![catch {::vfs::filesystem info $mountpoint} handler]} {
+	regexp {vfs::([^:]+)::handler} $handler -> ns
+    } else {
+	# Let's assume this is a ns directly (not sure if this
+	# code path is a good idea in the long term, but it is
+	# helpful for testing)
+	set ns $mountpoint
+	package require vfs::${ns}
+    }
+    
+    set attrs [list "state"]
+    set res {}
+
+    if {![llength $args]} {
+	if {[info exists ns]} {
+	    foreach attr $attrs {
+		if {[info commands ::vfs::${ns}::$attr] != ""} {
+		    if {[catch {::vfs::${ns}::$attr} val]} {
+			return -code error "error reading filesystem attribute\
+			  \"$attr\": $val"
+		    } else {
+			lappend res -$attr $val
+		    }
+		}
+	    }
+	}
+	return $res
+    }
+    
+    if {![info exists ns]} {
+	return -code error "filesystem not known or not configurable"
+    }
+    
+    while {1} {
+	foreach {attr val} $args {
+	    set args [lrange $args 2 end]
+	    break
+	}
+	if {[info commands ::vfs::${ns}::$attr] != ""} {
+	    if {[catch {::vfs::${ns}::$attr $val} err]} {
+		return -code error "error setting filesystem attribute\
+		  \"$attr\": $err"
+	    } else {
+		set res $val
+	    }
+	} else {
+	    return -code error "filesystem attribute \"$attr\" not known"
+	}
+    }
+    if {[llength $args]} {
+	set attr [lindex $args 0]
+	if {[info commands ::vfs::${ns}::$attr] != ""} {
+	    if {[catch {::vfs::${ns}::$attr} val]} {
+		return -code error "error reading filesystem attribute\
+		  \"$attr\": $val"
+	    } else {
+		set res $val
+	    }
+	} else {
+	    return -code error "filesystem attribute \"$attr\" not known"
+	}
+    }
+    return $res
+}
+
 ::vfs::autoMountExtension "" ::vfs::mk4::Mount vfs
 ::vfs::autoMountExtension .bin ::vfs::mk4::Mount vfs
 ::vfs::autoMountExtension .kit ::vfs::mk4::Mount vfs