Version 21 of A template virtual filesystem

Updated 2004-12-29 03:18:55 by CMCc

SEH As a self-teaching exercise, I wrote a sample virtual filesystem that utilizes as much of the Tclvfs API as possible, although its function is trivially simple. The virtual filesystems included with the Tclvfs distribution are instructive, but they take a lot of shortcuts.


Discussion moved to Template tclvfs Discussion

Because it simply mirrors a real filesystem location, I believe this vfs is maximally featureful.

My aim for this vfs is to use it as a template for rapid development of new and more complex filesystems.

The Mount, Unmount and handler procedures are completely generic and should never need customization for new filesystems. Thus the task of creating a new virtual filesystem is reduced to filling in the procedures for handling the eight subcommands of the Tclvfs API, as well as mounting and unmounting specifics.


SEH -- 10/14/04 -- I tidied things up a bit, and added an execution trace to the 'close' command so that it will throw a proper error if an error occurs in the close callback procedure. Not too relevant for this vfs, but for more complex ones built on the template.

I also added a "-volume" option to the Mount command, so you can now do things like:

 ::vfs::template::Mount -volume $env(HOME) C:/

on Unix, and make pathnames originating on Windows acceptable. Problems syncing cross-platform filesystems solved! Schweet!

12/07/04 -- I had to rewrite the Access procedure to correct a misunderstanding about how the access handler worked; I took the opportunity to optimize it to minimize the number of disk reads required.

12/22/04 -- I made it more of a real template by removing references to "::vfs::template" within procedure bodies and replaced them with [namespace current]. Now the Mount, Unmount and handler procedures can be copied and pasted directly into new vfs code without editing.

 package require vfs 1

 namespace eval ::vfs::template {}

 # The template vfs simply mirrors a real directory to a virtual location.
 # Usage: Mount ?-volume? <real directory> <virtual directory>

 proc ::vfs::template::Mount {args} {
        set volume {}
        if {[lindex $args 0] == "-volume"} {set volume "-volume"}
        set pathto [eval MountProcedure $args]
        set path [lindex $pathto 0]
        set to [lindex $pathto 1]
        eval ::vfs::filesystem mount $volume \$to \[list [namespace current]::handler \$path\]
        ::vfs::RegisterMount $to [list [namespace current]::Unmount]
        if {[trace info execution close] == {}} {
                trace add execution close leave [namespace current]::CloseTrace
        }
        return $to
 }

 proc ::vfs::template::Unmount {to} {
        set to [file normalize $to]
        set path [lindex [::vfs::filesystem info $to] end]
        UnmountProcedure $path $to
        ::vfs::filesystem unmount $to
 }

 proc ::vfs::template::CloseTrace {commandString code result op} {
        set errorCode $::errorCode
        set errorInfo $::errorInfo
        set channelID [lindex $commandString 1]
        if [regexp {::Close ([^ ]+?) } $errorInfo trash errorChannelID] {
                if [string equal $channelID $errorChannelID] {
                        if {[lindex $errorCode 0] == "POSIX"} {
                                set pError [lindex $errorCode 1]
                                ::vfs::filesystem posixerror $::vfs::posix($pError) ; return -code error $::vfs::posix($pError)
                        }
                        set message [lindex [split $errorInfo \n] 0]
                        error $message $errorInfo $errorCode
                }
        }
 }

 proc ::vfs::template::handler {path cmd root relative actualpath args} {
        switch -- $cmd {
                access {
                        set mode [lindex $args 0]
                        set error [catch {Access $path $root $relative $actualpath $mode}]
                        if $error {::vfs::filesystem posixerror $::vfs::posix(EACCES) ; return -code error $::vfs::posix(EACCES)}

CMcC I'm guessing that [::vfs::filesystem posixerror] simulates a [return -code -1] in the calling tcl, which indicates to the tclvfs caller that access is denied.

                }
                createdirectory {
                        CreateDirectory $path $root $relative $actualpath
                }
                deletefile {
                        DeleteFile $path $root $relative $actualpath
                }
                fileattributes {
                        set index [lindex $args 0]
                        set value [lindex $args 1]
                        if [info exists [namespace current]::attributes([file join $root $relative])] {
                                array set attributes [set [namespace current]::attributes([file join $root $relative])]
                        } else {
                                array set attributes [FileAttributes $path $root $relative $actualpath]
                                set [namespace current]::attributes([file join $root $relative]) [array get attributes]
                        }
                        if {$index == {}} {
                                return [lsort [array names attributes]]
                        }
                        set attribute [lindex [lsort [array names attributes]] $index]
                        if {$value == {}} {
                                return $attributes($attribute)
                        }
                        FileAttributesSet $path $root $relative $actualpath $attribute $value
                        array unset [namespace current]::attributes [file join $root $relative]
                }
                matchindirectory {
                        set pattern [lindex $args 0]
                        set types [lindex $args 1]
                        return [MatchInDirectory $path $root $relative $actualpath $pattern $types]
                } open {
                        set mode [lindex $args 0]
                        if {$mode == {}} {set mode r}
                        set permissions [lindex $args 1]
                        set channelID [Open $path $root $relative $actualpath $mode $permissions]
                        fconfigure $channelID -translation auto
                        switch -glob -- $mode {
                                "" -
                                "r*" -
                                "w*" {
                                        seek $channelID 0
                                }
                                "a*" {
                                            seek $channelID 0 end
                                }
                                default {
                                        ::vfs::filesystem posixerror $::vfs::posix(EINVAL)
                                        return -code error $::vfs::posix(EINVAL)
                                }
                        }
                        set result $channelID
                        lappend result [list [namespace current]::Close $channelID $path $root $relative $actualpath $mode]
                        return $result
                }
                removedirectory {
                        set recursive [lindex $args 0]
                        if !$recursive {
                                if {[MatchInDirectory $path $root $relative $actualpath * 0] != {}} {
                                        ::vfs::filesystem posixerror $::vfs::posix(EEXIST)
                                        return -code error $::vfs::posix(EEXIST)
                                }
                        }
                        RemoveDirectory $path $root $relative $actualpath
                }
                stat {
                        return [Stat $path $root $relative $actualpath]
                }
                utime {
                        set atime [lindex $args 0]
                        set mtime [lindex $args 1]
                        Utime $path $root $relative $actualpath $atime $mtime
                }
        }
 }

 namespace eval ::vfs::template {

 proc MountProcedure {args} {
        foreach templateProc "Mount Unmount CloseTrace handler Access CreateDirectory DeleteFile FileAttributes FileAttributesSet MatchInDirectory Open RemoveDirectory Stat Utime" {
                set infoArgs [info args ::vfs::template::$templateProc]
                set infoBody [info body ::vfs::template::$templateProc]
                proc $templateProc $infoArgs $infoBody
        }
        if {[lindex $args 0] == "-volume"} {
                set args [lrange $args 1 end]
                set to [lindex $args end]
        } else {
                set to [file normalize [lindex $args end]]
        }
        set path [file normalize [lindex $args 0]]
        if [info exists ::vfs::_unmountCmd($to)] {::vfs::unmount $to}

        file mkdir $path
        array unset ::vfs::_unmountCmd $to
        lappend pathto $path
        lappend pathto $to
        return $pathto
 }

 proc UnmountProcedure {path to} {
        array unset ::vfs::_unmountCmd $to
        return
 }

 proc Access {path root relative actualpath mode} {
        set fileName [file join $path $relative]
        set modeString [::vfs::accessMode $mode]
        if {$modeString == "F"} {
                if [file exists $fileName] {return}
                error "no such file or directory"
        }
        set modeString [split $modeString {}]
        set fileString {}
        if {[string equal $modeString "R"] && [file readable $fileName]} {return}
        if {[string equal $modeString "W"] && [file writable $fileName]} {return}
        if {[string equal $modeString "X"] && [file executable $fileName]} {return}
        file stat $fileName stat
        foreach { mask pairs } {
                00400 { 00400 r }
                00200 { 00200 w }
                04100 { 04100 s 04000 S 00100 x }
                00040 { 00040 r }
                00020 { 00020 w }
                02010 { 02010 s 02000 S 00010 x }
                00004 { 00004 r }
                00002 { 00002 w }
                01001 { 01001 t 01000 T 00001 x }
            } {
                set value [expr $stat(mode) & $mask]
                set bit -
                foreach { x b } $pairs {
                    if { $value == $x } {
                        set bit $b
                    }
                }
                append bitString $bit
      }
        set readable [regexp -all "r" $bitString]
        set writable [regexp -all "w" $bitString]
        set executable [regexp -all "x" $bitString]
        foreach {mode count} "R $readable W $writable X $executable" {
                if {([string first $mode $modeString] > -1) && !$count} {error "$mode access not allowed"}
        }
        if [string equal $modeString "X W"] {
                if {($writable == 3) && ($executable == 3)} {
                        return
                } elseif [file writable $fileName] {
                        if {[regexp -all "wx" $bitString] == $writable} {
                                return
                        } elseif [file executable $fileName] {
                                return
                        }
                }
        }
        if [string equal $modeString "R W"] {
                if {($writable == 3) && ($readable == 3)} {
                        return
                } elseif [file writable $fileName] {
                        if {[regexp -all "rw" $bitString] == $writable} {
                                return
                        } elseif [file readable $fileName] {
                                return
                        }
                }
        }
        if [string equal $modeString "R X"] {
                if {($readable == 3) && ($executable == 3)} {
                        return
                } elseif [file executable $fileName] {
                        if {[regexp -all {r[w-]x} $bitString] == $executable} {
                                return
                        } elseif [file readable $fileName] {
                                return
                        }
                }
        }

        foreach mS $modeString {
                set errorMessage "not [string map {R readable W writable X executable} $mS]"
                if {[lsearch $fileString $mS] == -1} {error $errorMessage}
        }
 }

 proc CreateDirectory {path root relative actualpath} {
        file mkdir [file join $path $relative]
 }

 proc DeleteFile {path root relative actualpath} {
        set fileName [file join $path $relative]
        file delete $fileName
 }

 proc FileAttributes {path root relative actualpath} {
        set fileName [file join $path $relative]
        file attributes $fileName
 }

 proc FileAttributesSet {path root relative actualpath attribute value} {
        set fileName [file join $path $relative]
        file attributes $fileName $attribute $value
 }

 proc MatchInDirectory {path root relative actualpath pattern types} {
        if [::vfs::matchDirectories $types] {lappend typeString d}
        if [::vfs::matchFiles $types] {lappend typeString f}

        set globList [glob -directory [file join $path $relative] -nocomplain -types $typeString $pattern]
        if [catch {::vfs::filesystem info $path}] {append globList " [glob -directory [file join $path $relative] -nocomplain -types "$typeString hidden" $pattern]"}

        set newGlobList {}
        foreach gL $globList {
                set gL [eval file join \$root [lrange [file split $gL] [llength [file split $path]] end]]
                lappend newGlobList $gL
        }
        set newGlobList [lsort -unique $newGlobList]
        return $newGlobList
 }

 proc Open {path root relative actualpath mode permissions} {
        set fileName [file join $path $relative]
        set newFile 0
        if ![file exists $fileName] {set newFile 1}
        set channelID [open $fileName $mode]
        if $newFile {catch {file attributes $fileName -permissions $permissions}}
        return $channelID
 }

 proc Close {channelID path root relative actualpath mode} {
 # Do not close the channel in the close callback!
 # It will crash Tcl!  Honest!
 # The core will close the channel after you've taken what info you need from it.

 #        close $channelID
        return
 }

 proc RemoveDirectory {path root relative actualpath} {
        file delete -force [file join $path $relative]
 }

 proc Stat {path root relative actualpath} {
        file stat [file join $path $relative] fs
        return [list dev $fs(dev) ino $fs(ino) mode $fs(mode) nlink $fs(nlink) uid $fs(uid) gid $fs(gid) size $fs(size) atime $fs(atime) mtime $fs(mtime) ctime $fs(ctime) type $fs(type)]
 }

 proc Utime {path root relative actualpath atime mtime} {
        set fileName [file join $path $relative]
        file atime $fileName $atime
        file mtime $fileName $mtime
 }

 }
 # end namespace eval ::vfs::template


20040720 CMcC: I just saw a real use for this - a trace fs. Someone was trying to work out why copy -force was failing, it would have been nice to be able to say to them: mount this on your directory and look at the log. Trivial addition to this template - log each argument to, and result from, underlying file system.

snitvfs has a reimplementation of this, in Snit.


[ Category Example | Category VFS ]