Version 0 of Caching VFS

Updated 2003-11-11 14:41:45

#!/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

    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]
        }

        puts stderr "add-vfs: attempt to mount $dirs / $mps at $local"

        if {[llength $mps] < 2} {
            puts stderr "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
            puts stderr "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} {
        puts stderr "::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]
            puts stderr "_find $shadow"
            if {[file exists $shadow]} {
                return $shadow
            }
        }
        error "no such file $name"
    }

    proc vfs::add::stat {mps name} {
        puts stderr "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} {
        puts stderr "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} {
        puts stderr "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} {
        puts stderr "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} {
        puts stderr "createdirectory $name"
        file mkdir [file join [lindex $mps 0] $name]
    }

    proc vfs::add::removedirectory {mps name} {
        puts stderr "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} {
        puts stderr "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} {
        puts stderr "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]
        }

        puts stderr "cache-vfs: attempt to mount $dirs / $mps at $local"

        if {[llength $mps] < 2} {
            puts stderr "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
            puts stderr "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} {
        puts stderr "::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} {
        puts stderr "open $name $mode $permissions"

        switch -glob $mode {
            r {
                return [::open [::vfs::add:_find $mps $name] $mode $permissions]
            }

            r+ -
            a* {
                # copy the file
                if {![file exists [file join [lindex $mps 0] $name]]} {
                    catch {file copy [::vfs::add::_find $mps $name] [lindex $mps 0]}
                }
                return [::open [file join [lindex $mps 0] $name] $mode $permissions]
            }

            w* {
                return [::open [file join [lindex $mps 0] $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 Mounted

        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/*]"
    }