readonly support added

diff --git a/ChangeLog b/ChangeLog
index b45355282ddce41c642a0f4c261df1b27559d89c..7f0849ea894c18ee684d60989d157283549169a3 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,21 @@
+2003-02-18  Vince Darley <vincentdarley@sourceforge.net>
+
+       * generic/vfs.c: added 'vfs::filesystem posixerror' command
+       to allow direct reporting of posix error codes to Tcl.
+       * library/vfsUtils.tcl: added support for state switching
+       between "readonly", "translucent" and "readwrite".
+       * library/mk4vfs.tcl: 
+       * library/tarvfs.tcl:
+       * library/zipvfs.tcl:
+       * library/httpvfs.tcl: added support for proper reporting
+       of read-only status of filesystem
+       * library/tclIndex:  regen.
+       
+        You can now switch an mk4 filesystem between translucent and
+       readonly with 'vfs::attributes $mount -state readonly'. All
+       errors etc are correctly reported as if the filesystem is
+       read-only.
+       
 2003-02-17  Vince Darley <vincentdarley@sourceforge.net>
 
        * library/vfsUtils.tcl: added beginnings of interface for

diff --git a/generic/vfs.c b/generic/vfs.c
index f49ee020b787fa935cbc825c40fc8adce130e911..3d8d2be077528ef820248bc1d4c5464b903d21f0 100644 (file)
--- a/generic/vfs.c
+++ b/generic/vfs.c
@@ -680,11 +680,11 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv)
     int index;
 
     static CONST char *optionStrings[] = {
-       "info", "mount", "unmount", "fullynormalize",
+       "info", "mount", "unmount", "fullynormalize", "posixerror", 
        NULL
     };
     enum options {
-       VFS_INFO, VFS_MOUNT, VFS_UNMOUNT, VFS_NORMALIZE
+       VFS_INFO, VFS_MOUNT, VFS_UNMOUNT, VFS_NORMALIZE, VFS_POSIXERROR
     };
 
     if (objc < 2) {
@@ -697,6 +697,18 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv)
     }
 
     switch ((enum options) index) {
+       case VFS_POSIXERROR: {
+           int posixError = -1;
+           if (objc != 3) {
+               Tcl_WrongNumArgs(interp, 2, objv, "errorcode");
+               return TCL_ERROR;
+           }
+           if (Tcl_GetIntFromObj(NULL, objv[2], &posixError) != TCL_OK) {
+               return TCL_ERROR;
+           }
+           Tcl_SetErrno(posixError);
+           return TCL_OK;
+       }
        case VFS_NORMALIZE: {
            Tcl_Obj *path;
            if (objc != 3) {

diff --git a/library/httpvfs.tcl b/library/httpvfs.tcl
index 061f8c4da7cf223458a4964995ce8cba060814af..d6f30dddc3388cde6bbfba7c5edd20aef196be7c 100644 (file)
--- a/library/httpvfs.tcl
+++ b/library/httpvfs.tcl
@@ -81,6 +81,9 @@ proc vfs::http::stat {dirurl name} {
 
 proc vfs::http::access {dirurl name mode} {
     ::vfs::log "access $name $mode"
+    if {$mode & 2} {
+       return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+    }
     if {$name == ""} { return 1 }
     set state [::http::geturl "$dirurl$name"]
     set info ""
@@ -114,7 +117,7 @@ proc vfs::http::open {dirurl name mode permissions} {
        }
        "a" -
        "w*" {
-           error "Can't open $name for writing"
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
        }
        default {
            return -code error "illegal access mode \"$mode\""
@@ -141,17 +144,17 @@ proc vfs::http::matchindirectory {dirurl path actualpath pattern type} {
 
 proc vfs::http::createdirectory {dirurl name} {
     ::vfs::log "createdirectory $name"
-    error "read-only"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 
 proc vfs::http::removedirectory {dirurl name} {
     ::vfs::log "removedirectory $name"
-    error "read-only"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 
 proc vfs::http::deletefile {dirurl name} {
     ::vfs::log "deletefile $name"
-    error "read-only"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 
 proc vfs::http::fileattributes {dirurl path args} {
@@ -169,12 +172,12 @@ proc vfs::http::fileattributes {dirurl path args} {
            # set value
            set index [lindex $args 0]
            set val [lindex $args 1]
-           error "read-only"
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
        }
     }
 }
 
 proc vfs::http::utime {dirurl path actime mtime} {
-    error "Can't set utime"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 

diff --git a/library/mk4vfs.tcl b/library/mk4vfs.tcl
index b54f7bb1d348ea1fe86f633447811bf14c52df33..3a76d4d0e5d613a85264691b4fe12311dc162013 100644 (file)
--- a/library/mk4vfs.tcl
+++ b/library/mk4vfs.tcl
@@ -59,10 +59,16 @@ namespace eval vfs::mk4 {
     proc state {db args} {
        switch -- [llength $args] {
            0 {
-               return "translucent"
+               return $::mk4vfs::v::mode($db)
            }
            1 {
-               return -code error "Can't set state yet"
+               set val [lindex $args 0]
+               if {[lsearch -exact [::vfs::states] $val] == -1} {
+                   return -code error \
+                     "invalid state $val, must be one of: [vfs::states]"
+               }
+               set ::mk4vfs::v::mode($db) $val
+               ::mk4vfs::setupCommits $db
            }
            default {
                return -code error "Wrong num args"
@@ -111,8 +117,13 @@ namespace eval vfs::mk4 {
        array get sb
     }
 
-    proc access {db name mode} {
-       # This needs implementing better.  
+    proc vfs::mk4::access {db name mode} {
+       if {$mode & 2} {
+           if {$::mk4vfs::v::mode($db) == "readonly"} {
+               return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+           }
+       }
+       # We can probably do this more efficiently, can't we?
        ::mk4vfs::stat $db $name sb
     }
 
@@ -153,6 +164,9 @@ namespace eval vfs::mk4 {
                return [list $fd]
            }
            a {
+               if {$::mk4vfs::v::mode($db) == "readonly"} {
+                   return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+               }
                if { [catch {::mk4vfs::stat $db $file sb }] } {
                    # Create file
                    ::mk4vfs::stat $db [file dirname $file] sb
@@ -186,9 +200,12 @@ namespace eval vfs::mk4 {
                }
                fconfigure $fd -translation auto
                seek $fd 0 end
-               return [list $fd [list mk4vfs::do_close $fd $mode $sb(ino)]]
+               return [list $fd [list mk4vfs::do_close $db $fd $mode $sb(ino)]]
            }
            w*  {
+               if {$::mk4vfs::v::mode($db) == "readonly"} {
+                   return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+               }
                if { [catch {::mk4vfs::stat $db $file sb }] } {
                    # Create file
                    ::mk4vfs::stat $db [file dirname $file] sb
@@ -208,7 +225,7 @@ namespace eval vfs::mk4 {
                } else {
                    set fd [mk::channel $sb(ino) contents w]
                }
-               return [list $fd [list mk4vfs::do_close $fd $mode $sb(ino)]]
+               return [list $fd [list mk4vfs::do_close $db $fd $mode $sb(ino)]]
            }
            default   {
                error "illegal access mode \"$mode\""
@@ -242,6 +259,9 @@ namespace eval vfs::mk4 {
            }
            2 {
                # set value
+               if {$::mk4vfs::mode($db) == "readonly"} {
+                   return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+               }
                set index [lindex $args 0]
                set val [lindex $args 1]
                return [::vfs::attributesSet $root $relative $index $val]
@@ -258,13 +278,14 @@ namespace eval mk4vfs {
 
     namespace eval v {
        variable seq      0
-       variable mode       ;# array key is db, value is mode (rw/ro/nc)
+       variable mode       ;# array key is db, value is mode 
+                            # (readwrite/translucent/readonly)
        variable timer      ;# array key is db, set to afterid, periodicCommit
 
        array set cache {}
        array set fcache {}
 
-       array set mode {exe ro}
+       array set mode {exe translucent}
     }
 
     namespace export mount umount
@@ -290,24 +311,24 @@ namespace eval mk4vfs {
        set db mk4vfs[incr v::seq]
 
        if {$file == ""} {
-         mk::file open $db
-         init $db
-         set v::mode($db) ro
+           mk::file open $db
+           init $db
+           set v::mode($db) "translucent"
        } else {
-         eval [list mk::file open $db $file] $args
-
-         init $db
-
-         set v::mode($db) rw
-         for {set idx 0} {$idx < [llength $args]} {incr idx} {
-             switch -- [lindex $args $idx] {
-                 -readonly   { set v::mode($db) ro }
-                 -nocommit   { set v::mode($db) nc }
-             }
-         }
-         if {$v::mode($db) == "rw"} {
-           periodicCommit $db
-         }
+           eval [list mk::file open $db $file] $args
+           
+           init $db
+           
+           set v::mode($db) "readwrite"
+           for {set idx 0} {$idx < [llength $args]} {incr idx} {
+               switch -- [lindex $args $idx] {
+                   -readonly   { set v::mode($db) "readonly" }
+                   -nocommit   { set v::mode($db) "translucent" }
+               }
+           }
+           if {$v::mode($db) == "readwrite"} {
+               periodicCommit $db
+           }
        }
        return $db
     }
@@ -439,7 +460,7 @@ namespace eval mk4vfs {
        }
     }
 
-    proc do_close {fd mode cur} {
+    proc do_close {db fd mode cur} {
        if {![regexp {[aw]} $mode]} {
            error "mk4vfs::do_close called with bad mode: $mode"
        }
@@ -462,17 +483,21 @@ namespace eval mk4vfs {
            mk::set $cur size [mk::get $cur -size contents]
        }
        # 16oct02 new logic to start a periodic commit timer if not yet running
-       setupCommits [lindex [split $cur .] 0]
+       setupCommits $db
+       return ""
     }
 
     proc setupCommits {db} {
-       if {$v::mode($db) ne "ro" && ![info exists v::timer($db)]} {
+       if {$v::mode($db) eq "readwrite" && ![info exists v::timer($db)]} {
            periodicCommit $db
            mk::file autocommit $db
        }
     }
 
     proc mkdir {db path} {
+       if {$v::mode($db) == "readonly"} {
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+       }
        set sp [::file split $path]
        set parent 0
        set view $db.dirs
@@ -494,6 +519,7 @@ namespace eval mk4vfs {
            set parent [mk::cursor position cur]
        }
        setupCommits $db
+       return ""
     }
 
     proc getdir {db path {pat *}} {
@@ -515,6 +541,9 @@ namespace eval mk4vfs {
     }
 
     proc mtime {db path time} {
+       if {$v::mode($db) == "readonly"} {
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+       }
        stat $db $path sb
        if { $sb(type) == "file" } {
            mk::set $sb(ino) date $time
@@ -524,6 +553,9 @@ namespace eval mk4vfs {
 
     proc delete {db path {recursive 0}} {
        #puts stderr "mk4delete db $db path $path recursive $recursive"
+       if {$v::mode($db) == "readonly"} {
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+       }
        stat $db $path sb
        if {$sb(type) == "file" } {
            mk::row delete $sb(ino)

diff --git a/library/tarvfs.tcl b/library/tarvfs.tcl
index 2369ff915b19cf7f58226b585f2c5d1980fc9498..556758fed46f5619654082e8f528ef0987b0beb2 100644 (file)
--- a/library/tarvfs.tcl
+++ b/library/tarvfs.tcl
@@ -73,7 +73,7 @@ proc vfs::tar::stat {tarfd name} {
 
 proc vfs::tar::access {tarfd name mode} {
     if {$mode & 2} {
-       error "read-only"
+       return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
     }
     # Readable, Exists and Executable are treated as 'exists'
     # Could we get more information from the archive?
@@ -114,22 +114,25 @@ proc vfs::tar::open {tarfd name mode permissions} {
            return [list $nfd]
        }
        default {
-           return -code error "illegal access mode \"$mode\""
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
        }
     }
 }
 
 proc vfs::tar::createdirectory {tarfd name} {
-    error "tar-archives are read-only (not implemented)"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+    #error "tar-archives are read-only (not implemented)"
 }
 
 proc vfs::tar::removedirectory {tarfd name} {
     #::vfs::log "removedirectory $name"
-    error "tar-archives are read-only (not implemented)"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+    #error "tar-archives are read-only (not implemented)"
 }
 
 proc vfs::tar::deletefile {tarfd name} {
-    error "tar-archives are read-only (not implemented)"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
+    #error "tar-archives are read-only (not implemented)"
 }
 
 # don't care about platform-specific attributes
@@ -149,14 +152,14 @@ proc vfs::tar::fileattributes {tarfd name args} {
            # set value
            set index [lindex $args 0]
            set val [lindex $args 1]
-           error "tar-archives are read-only"
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
        }
     }
 }
 
-# is this needed??
+# set the 'mtime' of a file.
 proc vfs::tar::utime {fd path actime mtime} {
-    error ""
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 
 #

diff --git a/library/tclIndex b/library/tclIndex
index 6d19daf2b3deb19fd7dde5ad88f9cc26b39ac5d5..4723cffc6e959835a21d33e5e73f532963e8beae 100644 (file)
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -132,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::states) [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]]

diff --git a/library/vfsUtils.tcl b/library/vfsUtils.tcl
index 0f016fbf95405ad621adbfca2365cfb4b701d917..9be051022ba6a244c9da8750cf7166f5b6f1f1b1 100644 (file)
--- a/library/vfsUtils.tcl
+++ b/library/vfsUtils.tcl
@@ -59,6 +59,10 @@ proc ::vfs::unmount {mountpoint} {
     unset _unmountCmd($norm)
 }
 
+proc vfs::states {} {
+    return [list "readwrite" "translucent" "readonly"]
+}
+
 # vfs::attributes mountpoint ?-opt val? ?...-opt val?
 proc ::vfs::attributes {mountpoint args} {
     set handler [::vfs::filesystem info $mountpoint]

diff --git a/library/zipvfs.tcl b/library/zipvfs.tcl
index 9adde8f1f2c32a2fa4ef571f4a8f0c1399ed4ecc..62d636c25f35bcab1e1a67b2c8f6d6523e6bc9ac 100644 (file)
--- a/library/zipvfs.tcl
+++ b/library/zipvfs.tcl
@@ -73,7 +73,7 @@ proc vfs::zip::stat {zipfd name} {
 proc vfs::zip::access {zipfd name mode} {
     #::vfs::log "zip-access $name $mode"
     if {$mode & 2} {
-       error "read-only"
+       return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
     }
     # Readable, Exists and Executable are treated as 'exists'
     # Could we get more information from the archive?
@@ -114,24 +114,24 @@ proc vfs::zip::open {zipfd name mode permissions} {
            return [list $nfd]
        }
        default {
-           return -code error "illegal access mode \"$mode\""
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
        }
     }
 }
 
 proc vfs::zip::createdirectory {zipfd name} {
     #::vfs::log "createdirectory $name"
-    error "read-only"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 
 proc vfs::zip::removedirectory {zipfd name} {
     #::vfs::log "removedirectory $name"
-    error "read-only"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 
 proc vfs::zip::deletefile {zipfd name} {
     #::vfs::log "deletefile $name"
-    error "read-only"
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 
 proc vfs::zip::fileattributes {zipfd name args} {
@@ -150,13 +150,13 @@ proc vfs::zip::fileattributes {zipfd name args} {
            # set value
            set index [lindex $args 0]
            set val [lindex $args 1]
-           error "read-only"
+           return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
        }
     }
 }
 
 proc vfs::zip::utime {fd path actime mtime} {
-    error ""
+    return -code error [vfs::filesystem posixerror $::vfs::posix(EROFS)]
 }
 
 # Below copied from TclKit distribution