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
 }

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References