The idea of these two VFS '''add''' and '''cache''' 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/*]" }