I've written an updated version of the template vfs, with the goal of making it easier to write new Tcl virtual filesystems. The rewrite was primarily motivated by the fact that Tcl's new scripted channel feature makes it possible to force errors in the close callback into the foreground, thus making write-enabled vfs's more reliable and enabling me to rip out a lot of kludgey workaround code. Tclvfs and scripted channels are a perfect match, two great tastes that taste great together!
While I was at it I generally tidied up the code in hopes of making it more comprehensible and easier to use and improve. I hope the new version will prompt renewed interest in pushing forward with development of the tclvfs package and new virtual filesystems. I really think it is one of Tcl's killer advantages.
This new version requires the tilde package on the Tilde Substitution page and the stackchan package on the page A template reflected channel.
See Template tclvfs Discussion for comments on previous version.
if 0 {
########################
templatevfs.tcl --
Written by Stephen Huntley ([email protected])
License: Tcl license
Version 2.0
The template virtual filesystem is designed as a prototype on which to build new
virtual filesystems. Only a few simple, abstract procedures have to be
overridden to produce a new vfs, requiring no knowledge of the Tclvfs API.
In addition, several behind-the-scenes functions are provided to make new vfs's
more stable and scalable, including file metadata caching and management of
close callback errors.
The template vfs provides a useful function of its own, it mirrors a real
directory to a virtual location, analogous to a Unix-style link.
Usage:
mount ?-cache <number>? ?-volume? <existing directory> <virtual directory>
Options:
-cache
Sets number of seconds file stat and attributes information will dwell in cache
after being retrieved. Default is 2. Setting value of 0 will essentially
disable caching. This value is viewable and editable after mount by calling
"file attributes <virtual directory> -cache ?value?"
-volume
Volume specified in virtual directory pathname will be mounted as a virtual
volume.
#
The above options are inherited by all virtual filesystems built using the
template.
#
Side effects:
Files whose names begin with ".vfs_" will be ignored and thus
invisible to the user unless the variable ::vfs::template::vfs_retrieve exists.
Sourcing this file will run code that overloads the exit command with
a procedure that ensures that all vfs's are explicitly unmounted before the
shell terminates.
#
Creating and using a new VFS:
1. Name your new vfs type by assigning a new value to the global variable
"_vfs_template_vfsName" to replace the default value "::vfs::template". This
will create a new namespace with the name of the assigned value, to hold your
custom code and state information.
2. Delete all code after the end of the first namespace eval command argument,
where specified in the comments.
3. Override each proc within the namespace eval command argument with custom
code to handle the arguments passed in (except where contraindicated in
comments).
4. Source your new code. In addition to your custom procs, there will be a
"mount" and an "unmount" proc instantiated by the template code in your new
namespace.
5. Call the "mount" proc in your new namespace with arbitrary arguments, with
the desired virtual mount point as the last argument. The mount point and args
will be passed to the proc "MountProcedure". Process the args as desired in
custom code for that proc. Any extra custom args returned by "MountProcedure"
can be accessed by your overridden procs by optionally adding an argument named
"path" to the proc arglist. E.g.,
proc file_exists {file} {file exists $file}
can be changed to:
proc file_exists {file path} {puts $path ; file exists $file}
and the template code will ensure that extra arg values will be passed as a list
into the argument "path".
Extra arguments "root", "relative" and "actualpath" can also be added to the
arglist, which will contain the values passed to the vfs handler by the tclvfs
extension as described in the API docs.
6. To delete the vfs mountpoint, call the "unmount" command in the new
namespace with the virtual mountpoint as the sole argument. The mountpoint and
the extra args originally specified in the "mount" command will be passed to the
custom "UnmountCommand" proc, where you can perform any desired tasks prior to
unmounting of the vfs.
########################
}
# define a unique namespace for a new virtual filesystem based on the template
# by giving the variable _vfs_template_vfsName a value corresponding to the name
# of the namespace to be created:
set _vfs_template_vfsName ::vfs::template
namespace eval $_vfs_template_vfsName {
# edit following procedures in order to create a new custom filesystem based
# on the template:
# Do not close channel within this procedure (will cause error). Simply
# read info from channel as needed and return.
proc close_ {channel} {
seek $channel 0
# puts [read $channel]
return
}
# Variable $time is always defined. These procs only set time values.
proc file_atime {file time} {file atime $file $time}
proc file_mtime {file time} {file mtime $file $time}
proc file_attributes_get {file} {file attributes $file}
proc file_attributes_set {file attribute value} {file attributes $file $attribute $value}
# Variable $file may be a file or directory.
# This proc only called if it is certain that deletion is the correct action.
proc file_delete {file} {file delete -force -- $file}
proc file_executable {file} {file executable $file}
proc file_exists {file} {file exists $file}
proc file_mkdir {file} {file mkdir $file}
proc file_readable {file} {file readable $file}
proc file_stat {file} {file stat $file fs ; array get fs}
proc file_writable {file} {file writable $file}
# All variables are always defined.
# Return list of filenames only, not full pathnames.
proc glob_ {dir typeString pattern} {
glob -directory $dir -nocomplain -tails -types $typeString -- $pattern
}
proc open_ {file mode {permissions 438}} {open $file $mode $permissions}
# MountProcedure is called once each time a vfs is newly mounted. The contents
# of this proc are specific to the example usage (i.e. providing simple
# reflection of a real directory location to a virtual mountpoint) and may be
# replaced with any code deemed suitable (as long as the return values are as
# described herebelow).
#
# The return value should be a list with at least one element, the location of
# the mountpoint of the virtual filesystem (assigned to the variable $to below).
# Any additional list elements returned will be prepended to the call passed to
# the handler code, and thus may be accessed by the custom filesystem code.
#
# The mountpoint value (e.g. $to) must be the first value in the returned list.
# Actual mounting of the filesystem at the mountpoint will be done automatically
# and need not be addressed here.
proc MountProcedure {to args} {
array set flags [handleFlags $args]
set path [::file normalize $flags(-path)]
if {$path eq $to} {
error "must specify two separate pathnames as real and virtual locations."
}
# make sure mount location exists:
::file mkdir $path
# return two-item list consisting of real and virtual locations.
lappend topath $to
lappend topath $path
return $topath
}
proc UnmountProcedure {to args} {
# Add custom unmount handling of new vfs elements here.
# Actual unmounting of the filesystem will be done automatically and need not be
# addressed here.
return
}
# Do not edit this procedure:
proc initialize {} {
if {[namespace current] ne "::vfs::template"} {
package require vfs::template 2.0
namespace import -force ::vfs::template::*
proc mount args [info body ::vfs::template::mount]
unset -nocomplain _vfs_template_vfsName
return -code return
}
}
# make sure the call to initialize remains the last statement in the custom namespace:
initialize
} ; # end custom namespace
# All code below this point is meant for the ::vfs::template namespace only and
# should be deleted in new filesystem code based on the template:
namespace eval ::vfs::template {
proc template_initialize {} {
package require Tcl 8.5.0
package require vfs 1.4
package require stackchan
package require tilde
if {[catch {package present vfslib}]} {
foreach ap $::auto_path {
set vfslib [file join $ap vfslib.tcl]
if {[file isfile $vfslib]} {
namespace eval :: [list source $vfslib]
break
}
}
}
namespace import -force ::tilde::*
namespace export unmount handleFlags
package provide vfs::template 2.0
}
# A utility proc to parse arbitrary option switches. It allows zero or more
# values per switch. Processing ends with "--" if that value is found in the
# args list. Returns a dict where the keys are switch names and values are lists
# of options for the switch.
proc handleFlags {args} {
if {[llength $args] == 1} {
set args [concat {*}$args]
}
lappend args --
set twodash [lsearch $args --]
set args [lrange $args 0 [expr $twodash -1]]
set flags [lsearch -all $args -*]
set fIndex [llength $flags]
lappend flags [llength $args]
for {set i 0} {$i < $fIndex} {incr i} {
set flagName [lindex $args [lindex $flags $i]]
set rangeStart [expr [lindex $flags $i] +1]
set rangeEnd [expr [lindex $flags [expr $i + 1]] - 1]
array set flagArray [list $flagName [lrange $args $rangeStart $rangeEnd]]
}
return [array get flagArray]
}
proc mount {args} {
namespace eval [namespace current] {namespace import -force ::tilde::*}
set nspace [namespace current]
set flags(-cache) 2
set to [lindex $args end]
array set flags [handleFlags [lrange $args 0 end-1]]
if {[set volume [array names flags -exact -volume]] eq {}} {
set to [::file normalize $to]
catch {::file mkdir [file dirname $to]}
} else {
set sep [file separator]
if {[string index $to end] ne $sep} {
set to "$to$sep"
}
}
set cache $flags(-cache)
unset flags(-cache)
unset -nocomplain flags(-volume)
set args [concat {*}[array get flags]]
set mountArgs [MountProcedure $to {*}$args]
if {$mountArgs ne {}} {
set to [lindex $mountArgs 0]
set mountArgs [lreplace $mountArgs 0 0]
} else {
set mountArgs $to
}
set ::vfs::template::cache($to) $cache
if {[lsearch [::vfs::filesystem info] $to] != -1} {
catch {::vfs::unmount $to}
}
if {[lsearch [::vfs::filesystem info] $to] != -1} {::vfs::filesystem unmount $to}
::vfs::filesystem mount {*}$volume $to [list ::vfs::template::handler $mountArgs]
::vfs::RegisterMount $to [list ${nspace}::unmount]
return $to
}
proc unmount {to} {
if {[lsearch [::vfs::filesystem info] $to] < 0} {
set to [::file normalize $to]
}
set nsp $::vfs::_unmountCmd($to)
set nspace [namespace qualifier $nsp]
set info [::vfs::filesystem info $root]
set mountArgs [lindex $info end]
# call custom unmount procedure:
namespace inscope $nspace UnmountProcedure $to {*}$mountArgs
::vfs::filesystem unmount $to
# clear file info caches:
CacheClear $nspace $to
}
# vfshandler command required by Tclvfs API:
proc handler {path cmd root relative actualpath args} {
set nsp $::vfs::_unmountCmd($root)
set nspace [namespace qualifier $nsp]
set virtualName [tfile join $root $relative]
switch -- $cmd {
access {
set mode [lindex $args 0]
set error [catch {Access $nspace $path $root $relative $actualpath $mode}]
if $error {::vfs::filesystem posixerror $::vfs::posix(EACCES) ; return -code error $::vfs::posix(EACCES)}
}
createdirectory {
CreateDirectory $nspace $path $root $relative $actualpath
CacheClear $nspace $virtualName
}
deletefile {
DeleteFile $nspace $path $root $relative $actualpath
CacheClear $nspace $virtualName
}
fileattributes {
set index [lindex $args 0]
if {[llength $args] > 1} {set value [lindex $args 1]}
set extra {}
if [string equal $relative {}] {set extra "-cache $::vfs::template::cache($root)"}
# try to get values from cache first:
array set attributes [CacheGet ${nspace}::attributes $virtualName $::vfs::template::cache($root)]
# if not in cache, get them from file:
if [string equal [array get attributes] {}] {
array set attributes "[FileAttributes $nspace $path $root $relative $actualpath] $extra"
CacheSet ${nspace}::attributes $virtualName [array get attributes]
}
set attribute [lindex [lsort [array names attributes]] $index]
# if value given in args, set it and return:
if [info exists value] {
if [string equal $attribute "-cache"] {
set ::vfs::template::cache($root) $value
} else {
FileAttributesSet $nspace $path $root $relative $actualpath $attribute $value
}
CacheClear $nspace $virtualName
return
}
# if attribute given in args, return its value:
if ![string equal $index {}] {
return $attributes($attribute)
}
# otherwise, just return all attribute names
return [lsort [array names attributes]]
}
matchindirectory {
set pattern [lindex $args 0]
set types [lindex $args 1]
return [MatchInDirectory $nspace $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 $nspace $path $root $relative $actualpath $mode $permissions]
switch -exact -- $mode {
r {
lappend stackmode read
}
r+ {
lappend stackmode read
lappend stackmode write
}
w {
lappend stackmode write
seek $channelID 0
}
w+ {
lappend stackmode read
lappend stackmode write
seek $channelID 0
}
a {
lappend stackmode write
seek $channelID 0 end
}
a+ {
lappend stackmode read
lappend stackmode write
seek $channelID 0 end
}
default {
::vfs::filesystem posixerror $::vfs::posix(EINVAL)
return -code error $::vfs::posix(EINVAL)
}
}
# Stack a scripted channel on top of the channel already created.
# Assign handler as custom close command. This ensures that
# errors on close will stop execution and unwind stack. Also
# allows fine control of read/write permission as workaround of
# Tclvfs bug #1004273. Winning!
set stackchan [::stackchan::stackchan $channelID $stackmode [list [namespace current]::handler $path close $root $relative $actualpath $channelID $mode]]
CacheClear $nspace $virtualName
return $stackchan
} close {
set channelID [lindex $args 0]
set mode [lindex $args 1]
if [string equal $mode "r"] {return}
set procargs [procArgs close_]
namespace inscope $nspace close_ $channelID {*}$procargs
close $channelID
}
removedirectory {
set recursive [lindex $args 0]
if !$recursive {
if {[MatchInDirectory $nspace $path $root $relative $actualpath * 0] ne {}} {
::vfs::filesystem posixerror $::vfs::posix(EEXIST)
return -code error $::vfs::posix(EEXIST)
}
}
if {$relative == {}} {namespace inscope $nspace unmount $root ; return}
RemoveDirectory $nspace $path $root $relative $actualpath
CacheClear $nspace $virtualName
}
stat {
set stat [CacheGet ${nspace}::stat $virtualName $vfs::template::cache($root)]
if {$stat ne {}} {
return $stat
}
set stat [Stat $nspace $path $root $relative $actualpath]
CacheSet ${nspace}::stat $virtualName $stat
return $stat
}
utime {
set atime [lindex $args 0]
set mtime [lindex $args 1]
Utime $nspace $path $root $relative $actualpath $atime $mtime
array unset ${nspace}::stat $virtualName,time ; array unset ${nspace}::stat $virtualName,value
}
}
return
}
# following commands carry out information processing requirements for each vfshandler subcommand:
# note that all calls to file commands are redirected to simplified API procs at top of this script
proc Access {nspace path root relative actualpath mode} {
if {[string match .vfs_* [file tail $relative]] && ![info exists ::vfs::template::vfs_retrieve]} {error "restricted vfs file."}
set fileName [tfile join $path $relative]
set virtualName [tfile join $root $relative]
set modeString [::vfs::accessMode $mode]
set modeString [split $modeString {}]
set modeString [string map "F exists R readable W writable X executable" $modeString]
set secs [clock seconds]
foreach mode $modeString {
set result [CacheGet ${nspace}::$mode $virtualName $::vfs::template::cache($root) $secs]
if [string equal $result ""] {
set procargs [procArgs file_$mode]
set filemode ${nspace}::file_$mode
set result [$filemode $fileName {*}$procargs]
CacheSet ${nspace}::$mode $virtualName $result $secs
}
if !$result {error error}
}
}
proc CreateDirectory {nspace path root relative actualpath} {
set procargs [procArgs file_mkdir]
namespace inscope $nspace file_mkdir [tfile join $path $relative] {*}$procargs
}
proc DeleteFile {nspace path root relative actualpath} {
set procargs [procArgs file_delete]
namespace inscope $nspace file_delete [tfile join $path $relative] {*}$procargs
}
proc FileAttributes {nspace path root relative actualpath} {
set procargs [procArgs file_attributes_get]
namespace inscope $nspace file_attributes_get [tfile join $path $relative] {*}$procargs
}
proc FileAttributesSet {nspace path root relative actualpath attribute value} {
set procargs [procArgs file_attributes_set]
namespace inscope $nspace file_attributes_set [tfile join $path $relative] $attribute $value {*}$procargs
}
proc MatchInDirectory {nspace path root relative actualpath pattern types} {
# special case: check for existence (see Tclvfs bug #1405317)
if [string equal $pattern {}] {
if ![::vfs::matchDirectories $types] {return {}}
return [tfile join $root $relative]
}
# convert types bitstring back to human-readable alpha string:
foreach {type shift} {b 0 c 1 d 2 p 3 f 4 l 5 s 6} {
if [expr {$types == 0 ? 1 : $types & (1<<$shift)}] {lappend typeString $type}
}
set pathName [tfile join $path $relative]
# get non-hidden files:
set procargs [procArgs glob_]
set globList [namespace inscope $nspace glob_ $pathName $typeString $pattern {*}$procargs]
# if underlying location is not itself a vfs, get hidden files (Tclvfs doesn't pass "hidden" type to handler)
set hidn [list]
if {[catch {::vfs::filesystem info $pathName}]} {
set hidn [namespace inscope $nspace glob_ $pathName "$typeString hidden" $pattern {*}$procargs]
}
set idx [lsearch -exact $hidn {.}]
set hidn [lreplace $hidn $idx $idx]
set idx [lsearch -exact $hidn {..}]
set hidn [lreplace $hidn $idx $idx]
set globList [concat $globList $hidn]
# convert real path to virtual path:
set newGlobList {}
set rtrv [info exists ::vfs::template::vfs_retrieve]
foreach gL $globList {
set gL [tfile tail $gL]
if {[string match .vfs_* $gL] && !$rtrv} {continue}
set gL [tfile join $root $relative $gL]
lappend newGlobList $gL
}
set newGlobList [lsort -unique $newGlobList]
return $newGlobList
}
proc Open {nspace path root relative actualpath mode permissions} {
set fileName [tfile join $path $relative]
if {[string match r* $mode]} {
set procargs [procArgs file_exists]
if {![namespace inscope $nspace file_exists $fileName {*}$procargs]} {
::vfs::filesystem posixerror $::vfs::posix(ENOENT)
return -code error $::vfs::posix(ENOENT)
}
}
# workaround: Tclvfs can't handle channels in write-only modes; see Tclvfs bug #1004273
if {$mode == "w"} {set mode w+}
if {$mode == "a"} {set mode a+}
set procargs [procArgs open_]
set channelID [namespace inscope $nspace open_ $fileName $mode $permissions {*}$procargs]
# ensure channel settings match file command defaults
set eofChar {{} {}}
if {[string equal $::tcl_platform(platform) "windows"]} {set eofChar "\x1a {}"}
fconfigure $channelID -encoding [encoding system] -eofchar $eofChar -translation auto
return $channelID
}
proc RemoveDirectory {nspace path root relative actualpath} {
set procargs [procArgs file_delete]
namespace inscope $nspace file_delete [tfile join $path $relative {*}$procargs]
}
proc Stat {nspace path root relative actualpath} {
set procargs [procArgs file_stat]
namespace inscope $nspace file_stat [tfile join $path $relative] {*}$procargs
}
proc Utime {nspace path root relative actualpath atime mtime} {
set fileName [tfile join $path $relative]
set virtualName [tfile join $root $relative]
set stat(atime) {}
set stat(mtime) {}
array set stat [CacheGet ${nspace}::stat $virtualName $vfs::template::cache($root)]
set procargs [procArgs file_atime]
if {$stat(atime) != $atime} {
namespace inscope $nspace file_atime $fileName $atime {*}$procargs
}
set procargs [procArgs file_mtime]
if {$stat(mtime) != $mtime} {
namespace inscope $nspace file_mtime $fileName $mtime {*}$procargs
}
}
# cache management functions:
proc CacheClear {nspace file} {
foreach arr {exists readable writable executable stat attributes} {
array unset ${nspace}::$arr $file,time
array unset ${nspace}::$arr $file,value
array unset ${nspace}::$arr $file/*
}
}
proc CacheGet {array file cache args} {
if [string equal [array names $array $file,time] {}] {return}
if ![string equal $args {}] {set secs $args} else {set secs [clock seconds]}
set fileTime [lindex [array get $array $file,time] 1]
if {[expr $secs - $fileTime] < $cache} {return [lindex [array get $array $file,value] 1]}
array unset $array $file,time ; array unset $array $file,value
return
}
proc CacheSet {array file value args} {
if ![string equal $args {}] {set secs $args} else {set secs [clock seconds]}
set fileTime $file,time
array set $array [list $fileTime $secs]
set fileValue $file,value
array set $array [list $fileValue $value]
}
proc procArgs {cmd} {
upvar nspace nspace path path root root relative relative actualpath actualpath
set args [namespace inscope $nspace info args $cmd]
set procargs [list]
foreach arg $args {
switch $arg {
path {lappend procargs $path}
root {lappend procargs $root}
relative {lappend procargs $relative}
actualpath {lappend procargs $actualpath}
}
}
return $procargs
}
template_initialize
} ; # end ::vfs::template namespace
rename ::exit ::vfs::template::exit
proc ::exit {{rcode 0}} {
foreach vfs [::vfs::filesystem info] {
if {[catch {::vfs::unmount $vfs} result]} {
puts "$vfs: $result"
}
}
::vfs::template::exit $rcode
}