The idea of these two VFS add and cache commands is to allow Plan9-like stacking of mounts - you can mount any directory over any other, and what you see from the mount is a conjunction of the two directories.
cache in addition redirects all modifications to the first directory in the stack, permitting one to cache modifications to (for example) a read-only file system. This could be handy for tclhttpd
Caveats/Warning: It's not completely tested, I haven't tested stacked directories containing subdirectories. It's also very badly documented, but I doubt it'll destroy your disk. Nov12th - new version fixes open semantics.
#!/usr/bin/tclsh
#
# vfs::add::Mount dirlist local
# - mounts the directories in $dirlist over local, so they behave as a single directory
#
# vfs::cache::Mount dirlist local
# - as for vfs::add, but all modifications go back to the first directory in the list
#
package require vfs
package provide vfs::add 1.1
namespace eval vfs::add {}
proc vfs::add::Mount {dirs local args} {
# ensure each submount is normalized
foreach mp [split $dirs] {
lappend mps [file normalize $mp]
}
::vfs::log "add-vfs: attempt to mount $dirs / $mps at $local"
if {[llength $mps] < 2} {
::vfs::log "add-vfs: add-vfs names are lists of dirs"
return -code error "add-vfs names are lists of dirs"
}
if {![catch {vfs::filesystem info $dirs}]} {
# unmount old mount
::vfs::log "add-vfs: unmounted old mount point at $dirs"
vfs::unmount $dirs
}
vfs::filesystem mount $local [list vfs::add::handler $mps]
# Register command to unmount
vfs::RegisterMount $local [list ::vfs::add::Unmount $mps]
return $mps
}
proc vfs::add::Unmount {mps local} {
vfs::filesystem unmount $local
}
proc vfs::add::handler {mps cmd root relative actualpath args} {
::vfs::log "::vfs::add handler $mps [llength $mps] $cmd $relative $actualpath $args"
if {$cmd == "matchindirectory"} {
eval [list $cmd $mps $relative $actualpath] $args
} else {
eval [list $cmd $mps $relative] $args
}
}
# If we implement the commands below, we will have a perfect
# virtual file system for remote add sites.
proc vfs::add::_find {mps name} {
foreach mp $mps {
set shadow [file join $mp $name]
::vfs::log "_find $shadow"
if {[file exists $shadow]} {
return $shadow
}
}
error "no such file $name"
}
proc vfs::add::_finddir {mps name} {
foreach mp $mps {
set shadow [file join $mp $name]
::vfs::log "_find $shadow"
if {[file exists $shadow]} {
return $mp
}
}
error "no such file $name"
}
proc vfs::add::stat {mps name} {
::vfs::log "stat $mps $name"
if {$name == ""} {
return [file stat [lindex $mps 0]]
}
# get information on the type of this file
return [file stat [_find $mps $name]]
}
proc vfs::add::access {mps name mode} {
::vfs::log "add-access $name $mode"
if {$name == ""} {
array set stat [file stat [lindex $mps 0]]
return [expr $stat(mode) & $mode]
}
# find our file
array set stat [file stat [_find $mps $name]]
return [expr $stat(mode) & $mode]
}
proc vfs::add::open {mps name mode permissions} {
::vfs::log "open $name $mode $permissions"
foreach mp $mps {
set shadow [file join $mp $name]
if {![catch {::open $shadow $mode $permissions} result]} {
return $result
}
}
error "open failed $name $mode $permissions"
}
proc vfs::add::matchindirectory {mps relative actualpath pattern type} {
::vfs::log "matchindirectory $mps $relative $actualpath $pattern $type"
foreach mp $mps {
set shadow [file join $mp $relative]
if {[file exists $shadow]} {
set filelist [glob -directory $shadow $pattern]
set matching [vfs::matchCorrectTypes $type $filelist $mp]
set preflen [expr [string length $mp] + 1]
foreach match $matching {
set matches([string range $match $preflen end]) 1
}
}
}
return [array names matches]
}
proc vfs::add::createdirectory {mps name} {
::vfs::log "createdirectory $name"
file mkdir [file join [lindex $mps 0] $name]
}
proc vfs::add::removedirectory {mps name} {
::vfs::log "removedirectory $name"
foreach mp $mps {
set shadow [file join $mp $name]
if {[file exists $shadow]} {
return [file delete $shadow]
}
}
error "No such file"
}
proc vfs::add::deletefile {mps name} {
::vfs::log "deletefile $name"
foreach mp $mps {
set shadow [file join $mp $name]
if {[file exists $shadow]} {
return [file delete $shadow]
}
}
error "No such file"
}
proc vfs::add::fileattributes {mps path args} {
::vfs::log "fileattributes $args"
switch -- [llength $args] {
0 {
# list strings
return [list]
}
1 {
# get value
set index [lindex $args 0]
}
2 {
# set value
set index [lindex $args 0]
set val [lindex $args 1]
}
}
}
proc vfs::add::utime {mps path actime mtime} {
error "Can't set utime"
}
namespace eval vfs::cache {}
proc vfs::cache::Mount {dirs local args} {
# ensure each submount is normalized
foreach mp [split $dirs] {
lappend mps [file normalize $mp]
}
::vfs::log "cache-vfs: attempt to mount $dirs / $mps at $local"
if {[llength $mps] < 2} {
::vfs::log "cache-vfs: cache-vfs names are lists of dirs"
return -code error "cache-vfs names are lists of dirs"
}
if {![catch {vfs::filesystem info $dirs}]} {
# unmount old mount
::vfs::log "cache-vfs: unmounted old mount point at $dirs"
vfs::unmount $dirs
}
vfs::filesystem mount $local [list vfs::cache::handler $mps]
# Register command to unmount
vfs::RegisterMount $local [list ::vfs::add::Unmount $mps]
return $mps
}
proc vfs::cache::handler {mps cmd root relative actualpath args} {
::vfs::log "::vfs::cache handler $mps [llength $mps] $cmd $relative $actualpath $args"
if {$cmd == "matchindirectory"} {
eval [list ::vfs::add::$cmd $mps $relative $actualpath] $args
} elseif {$cmd == "open"} {
eval [list $cmd $mps $relative] $args
} else {
eval [list ::vfs::add::$cmd $mps $relative] $args
}
}
proc vfs::cache::open {mps name mode permissions} {
::vfs::log "open $name $mode $permissions"
set cache [lindex $mps 0]
switch -glob $mode {
r {
# don't copy.
return [::open [::vfs::add:_find $mps $name] $mode $permissions]
}
a* {
if {[catch {set original [::vfs::add::_find $mps $name]}]} {
::vfs::log "open $mode - original file doesn't exist"
# the file doesn't exist - create intervening dirs
if {![catch {::vfs::add::_finddir $mps [file dirname $name]}]} {
file mkdir [file join $cache [file dirname $name]]
}
} else {
::vfs::log "open $mode - original file $original"
# the file exists - create intervening dirs
file mkdir [file join $cache [file dirname $name]]
# copy the original to cache dir
if {[file dirname $original] != [file dirname [file join $cache $name]]} {
file copy $original [file join $cache $name]
}
}
}
r+ {
# file must exist in one of the dirs
set original [::vfs::add::_find $mps $name]
# make intervening dirs in cache dir
file mkdir [file join $cache [file dirname $name]]
# copy original to cache dir
file copy $original $cache
}
w* {
if {![catch {::vfs::add::_finddir $mps [file dirname $name]}]} {
file mkdir [file join $cache [file dirname $name]]
}
# will create in cache dir and truncate if needed
}
}
return [::open [file join $cache $name] $mode $permissions]
}
if {$argv0 == [info script]} {
set script [info script]
catch {file mkdir ./t1}
for {set i 3} {$i} {incr i -1} {
file copy -force $script ./t1/t1_$i
}
catch {file mkdir ./t2}
for {set i 3} {$i} {incr i -1} {
file copy -force $script ./t2/t2_$i
}
for {set i 3} {$i} {incr i -1} {
file copy -force $script ./t1/t0_$i
file copy -force $script ./t2/t0_$i
}
vfs::cache::Mount [list ./t1 ./t2] ./T12
puts stderr "[glob ./T12/*]"
set fd [open ./T12/newfile w]
puts $fd junk
close $fd
set fd [open ./T12/t2_1 a]
puts $fd junk
close $fd
puts stderr "[glob ./T12/*]"
# create a file in a new subdir
catch {file mkdir ./T12/s1}
set fd [open ./T12/s1/junk w]
puts $fd junk
close $fd
set fd [open ./T12/s1/junk a]
puts $fd junk
close $fd
puts stderr "[glob ./T12/*]"
}See also Cache VFS