[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 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! package require vfs 1 namespace eval ::vfs::template {} # The template vfs simply mirrors a real directory to a virtual location. # Usage: Mount ?-volume? 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 ::vfs::template::handler \$path\] ::vfs::RegisterMount $to [list ::vfs::template::Unmount] if {[trace info execution close] == {}} { trace add execution close leave ::vfs::template::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)} } 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 $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} { if {[lindex $args 0] == "-volume"} { set args [lrange $args 1 end] set to [lindex $args 1] } else { set to [file normalize [lindex $args 1]] } set path [file normalize [lindex $args 0]] if [info exists ::vfs::_unmountCmd($to)] {::vfs::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] set fileString {} 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 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] ]]