[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. 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 specific subcommands of the Tclvfs API, as well as mounting and unmounting specifics. package require vfs 1 namespace eval ::vfs::template {} # The template vfs simply mirrors a real directory to a virtual location. # Usage: Mount proc ::vfs::template::Mount {args} { set pathto [eval MountProcedure $args] set path [lindex $pathto 0] set to [lindex $pathto 1] ::vfs::filesystem mount $to [list ::vfs::template::handler $path] ::vfs::RegisterMount $to [list ::vfs::template::Unmount] return $to } proc ::vfs::template::Unmount {to} { set path [lindex [::vfs::filesystem info $to] end] UnmountProcedure $path $to ::vfs::filesystem unmount $to } 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)} } createdirectory { CreateDirectory $path $root $relative $actualpath } deletefile { DeleteFile $path $root $relative $actualpath } fileattributes { set index [lindex $args 0] set value [lindex $args 1] array set attributes [FileAttributes $path $root $relative $actualpath] 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 } 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] 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 ::vfs::template::Close $channelID $path $root $relative $actualpath] 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} { set path [lindex $args 0] set to [lindex $args 1] if {![catch {vfs::filesystem info $to}]} { # unmount old mount Unmount $to } file mkdir $path lappend pathto $path lappend pathto $to return $pathto } proc UnmountProcedure {path to} { return } proc Access {path root relative actualpath mode} { set modeString [::vfs::accessMode $mode] if {$modeString == "F"} {set modeString RWX} set modeString [split $modeString {}] set fileName [file join $path $relative] if [file readable $fileName] {lappend fileString R} if [file writable $fileName] {lappend fileString W} if [file executable $fileName] {lappend fileString X} 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] set pathLength [expr [string length $path] - 1] set newGlobList {} foreach gL $globList { set gL [string replace $gL 0 $pathLength $root] lappend newGlobList $gL } 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} { # 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] ]]