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.
LV Would it be beneficial a) to include this template with tclvfs and b) to upgrade the existing tclvfs examples with the features your template provide?
SEH I would love to have my work incorporated into the tcllib, but I don't think it's my decision.
CMcC With all respect to SEH, whose idea the template vfs is, I would like to suggest that the template vfs either be rewritten in Snit, or a parallel version in Snit written and maintained as part of the same package. I have rewritten Steve's template vfs in Snit, for the reasons I give below (although I'm not suggesting that my version is necessarily the best possible version.)
The reasons to use Snit for template vfs:
Rubbish reasons not to use Snit for vfs:
Real reasons not to use Snit for tclvfs:
Finally, the best reason for using Snit for tclvfs: Much of the need for this Template vfs is that the tclvfs raw interface has some anomalies and some lacks.
The template vfs is really a shim to provide:
Some of the provisions in point 1 can eventually be moved into the tclvfs C core. Doing this over an OO interface is (I believe) easier and less disruptive than doing it over a pure namespace implementation.
Therefore: I would like to argue, passionately, for at least *some* OO interface, and preferably Snit (because it seems to be the ostensive standard for pure tcl OO,) whether or not this is maintained in parallel with or alternative to a pure namespace template tclvfs shim. I would also like to see the existing tclvfs' migrated to whatever system is adopted, and new tclvfs' adhering to whatever that system is.
Addendum: Of course, if it's a choice between a raw namespace template vfs and a no template vfs at all, I would emphatically prefer the namespace template vfs.
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? <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 ::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} 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 ]