# Snit VFS handler

# Usage: vfs $name VFSType ...

# From https://wiki.tcl-lang.org/11938 by Steve Huntley, who writes:
#
# My aim for this vfs is to use it as a template for rapid development
# of new and more complex filesystems.
# The Mount, Unmount and handler procedures are completely generic and should
# never need customization for new filesystems.
#
# Thus the task of creating a new virtual filesystem is reduced to filling in the procedures
# for handling the eight specific subcommands of the Tclvfs API, as well as mounting and 
# unmounting specifics.

# createdirectory root relative actual
# Create a directory with the given name.  The command can  assume
# that  all  sub-directories  in the path exist and are valid, and
# that the actual desired path does not yet exist (Tcl takes care
# of all of that for us).

# deletefile root relative actual
# Delete the given file.

# matchindirectory root relative actual pattern types
#
# Return the list of files or directories in the given path (which
# is always the name of an existing directory), which match the
# pattern and are compatible with the types  given.
# It is very important  that  the command correctly handle types requests for
# directories only (and files only), because to handle any kind of
# recursive  globbing,  Tcl  will  actually  generate requests for
# directory-only matches from the filesystem.

# removedirectory root relative actual recursive
#
# Delete  the  given directory.
# If recursive is 1 then even if the directory is non-empty, an attempt  should
# be made  to recursively delete it and its contents.

# stat root relative actual
# Return  a  list  of  even length containing field-name and value
# pairs for the contents of a stat structure.  Order is not important.
#
# The  option  names are dev (long), ino (long), mode (int), nlink (long),
# uid (long), gid (long), size (long),  atime (long), mtime (long), ctime (long),
# type (string which is either "directory" or "file"),
# where the expected type of each argument is given in  brackets.

# utime root relative actual actime mtime

package provide snitvfs 2.0

package require Tcl 8.5
package require snit

#set ::env(VFS_DEBUG) 100
package require vfs 1
#set ::vfs::debug 100

proc Vfs_internalerror {args} {
    puts stderr "INTERNAL ERROR: $::errorInfo"
}

snit::type Vfs {
    component vfs -inherit yes -public vfs        ;# underlying vfs component
    variable stdattr

    # mirror the -debug option as a variable, for Debug's use
    option -debug -configuremethod debugon -default 0
    variable debug 0
    method debugon {option value} {
        set options(debug) $value
        set debug $value
    }

    constructor {vfs_type args} {
        # construct the vfs low level object
        Debug.vfs {vfs constructor type:$vfs_type args:$args}
        install vfs using $vfs_type %AUTO% $self {*}$args
        Debug.vfs {commands: $vfs - [$self cget -mount] - [info procs *]} 3

        $self configurelist $args

        # mount this object
        ::vfs::filesystem mount [$self cget -mount] $self
        ::vfs::filesystem internalerror ::Vfs_internalerror
            
        ::vfs::RegisterMount [$self cget -mount] [mymethod unmount]

        #set stdattr [vfs::listAttributes]
        set stdattr $::vfs::attributes(unix)
    }

    destructor {
        catch {set mount [$self cget -mount]}
        catch {$vfs destroy}
        catch {::vfs::filesystem unmount $mount}
    }

    # called when this is unmounted
    method unmount {args} {
        $self destroy
    }

    # Return TCL_OK or throw a posix error depending  on  whether  the
    # given  access  mode (which is an integer) is compatible with the file.
    method access {root relative actualpath mode} {
        Debug.vfs {access $root $relative $actualpath $mode}

        set modeString [::vfs::accessMode $mode]
        if {$modeString == "F"} {set modeString ""}
        set modeString [split $modeString {}]

        if {[catch {
            $vfs access $root $relative $actualpath $modeString $mode
        } result eo]} {
            Debug.vfs {snitvfs access $result ($eo)}
            vfs::filesystem posixerror $::vfs::posix(EACCES)
            return -code error $::vfs::posix(EACCES)
        }
        return $result
    }

    # allow perms values to be of the form [ugoa][+-=][wrx]+, for a more chmod feel
    method parsePerms {value} {
        array set m {u 0 g 0 o 0 a 0}
        if {[regexp {^([ugoa]*)([+-=])([wrx]+)(.*)$} $value x who op what rest]} {
            
            # calc the perms as an octal, then an integer
            set what [expr "[string map {r "4 +" w "2 +" x "1 +"} $what] 0"]
            foreach c [split $who] {
                set m($c) $what
            }
            if {$m(a)} {
                set m(u) $m(a)
                set m(g) $m(a)
                set m(o) $m(a)
            }
            set value [expr "0$m(u)$m(g)$m(o)" + 0]

            # work out what we want done with this bitmap
        } else {
            error "parsePerms '$value' doesn't parse"
        }
        return [list $op $value]
    }

    # If  neither  index nor value is given, then return a list of all
    # acceptable attribute names.  If index is given,  but  no  value,
    # then  retrieve  the value of the index'th attribute (counting in
    # order over the list returned when no argument is given) for  the
    # given  file.   If  a  value  is also given then set the index'th
    # attribute of the given file to that value.

    method fileattributes {root relative actualpath {index {}} {value {}}} {
        # get complete array of vfs-specific file attributes
        Debug.vfs {$self fileattributes $root $relative $actualpath index:$index value:$value}

        if {[catch {
            array set attributes [$vfs fileattributes $root $relative $actualpath]
        } err eo]} {
            Debug.vfs {$self fileattributes ERR: $err $eo}
            array set attributes {}
        }
        Debug.vfs {$self called fileattributes $index $value} 2

        # the set of all attributes is the standard set plus the fs-specific set
        set myattr [lsort -unique [concat $stdattr [array names attributes]]]

        if {$index == {}} {
            # what is wanted is the set of all attributes
            Debug.vfs {$self get all file attributes: $myattr} 2
            return $myattr
        }

        # we either want to set or get an attribute, by number

        # we want a standard attribute
        set attr [lindex $myattr $index]

        # map some standard attributes to something more usable
        # we only support the unix file attributes
        switch -- $attr {

            -group {
                set attribute -gid
                # interpret group as gid
            }

            -owner {
                set attribute -uid
                # interpret owner as uid
            }

            -permissions {
                set attribute -mode
                
                # parse permissions - why can they even *be* this wild?
                if {$value != {}} {
                    foreach {op value} [$self parsePerms $value] break;
                    switch -- $op {
                        + -
                        - {
                            # add or remove perms
                            return [$vfs permissions $root $relative $actualpath $op $value]
                        }
                        = {
                            # set perms - fall through
                        }
                        default {
                        }
                    }
                }
            }
            
            default {
                # we want a vfs-specific attribute
                Debug.vfs {FS specific attribute $attr}
                set attribute $attr
            }

        }

        if {$value == {}} {
            # return the attribute value
            Debug.vfs {$self get file attribute $index done - $attributes($attribute)}
            return $attributes($attribute)
        }

        Debug.vfs {$self calling setattribute $attribute $value} 2
        $vfs setattribute $root $relative $actualpath $attribute $value
        Debug.vfs {$self setattribute $attribute $value}
    }

    # For  this command, mode is any of "r", "w", "a", "w+", "a+".
    # If the open involves creating a  file,  then  permissions  dictates
    # what  modes  to  create  it with.
    #
    # If the open operation was not successful, an error should be thrown.
    # If the open operation is successful, the command should return 
    # a list of either one or two items.
    #
    # The first item is the name  of the  channel which has been created.
    #
    # The second item, if given, is a Tcl-callback to be used when the channel
    # is closed, so that the vfs can clean up as appropriate.
    # This callback will be evaluated by Tcl just before the channel is closed.
    #
    # The channel will  still exist, and all available data will have been flushed
    # into it.  The callback can, for example, seek to  the  beginning of  the channel,
    # read its contents and store that contents elsewhere
    # (e.g. compressed or on  a  remote  ftp  site,  etc).
    #
    # The return  code  or any errors returned by the callback are ignored
    # (if the callback wishes to signal an error, it must do so  asynchronously,
    # with bgerror, for example), unless the 'internalerror' has been specified,
    # when they  are  passed  to  that script for further action.

    method open {root relative actualpath {mode r} {permissions {}}} {
        Debug.vfs {$self open $root $relative $actualpath mode:$mode perms:0[format %o $permissions]}

        # call underlying open method, expecting a list whose first element is the fd.
        # the entire returned value will be added to the $self close method
        set result [$vfs open $root $relative $actualpath $mode $permissions]

        set channelID [lindex $result 0]
        switch -glob -- $mode {
            "" -
            "r*" -
            "w*" {
                catch {seek $channelID 0}
            }
            "a*" {
                catch {seek $channelID 0 end}
            }

            default {
                ::vfs::filesystem posixerror $::vfs::posix(EINVAL)
                return -code error $::vfs::posix(EINVAL)
            }
        }

        set callback [list $channelID [list $self close $root $relative $actualpath {*}$result]]
        Debug.vfs {$self open DONE: callback $callback}
        return $callback
    }

    # command removedirectory r-r-a recursive
    # Delete the given directory.
    #
    # recursive is either 0 or 1. If it is 1 then even if the directory is non-empty,
    # an attempt  should be  made  to recursively delete it and its contents.
    #
    # If it is 0 and the directory is non-empty, a posix error (EEXIST) should be
    # thrown.

    method removedirectory {root relative actualpath recursive} {
        Debug.vfs {$self removedirectory $root $relative $actualpath $recursive}

        if {!$recursive} {
            set contents [$vfs matchindirectory $root $relative $actualpath * 0]
            Debug.vfs {removedirectory contents: $contents}
            if {$contents != {}} {
                ::vfs::filesystem posixerror $::vfs::posix(EEXIST)
                return -code error $::vfs::posix(EEXIST)
            }
        }

        $vfs removedirectory $root $relative $actualpath $recursive
    }

    # return the subset of file attributes tcl vfs cares about
    method stat {root relative actual} {
        Debug.vfs {$self stat $root $relative $actual}

        # subset the relevant fields
        set result [dict filter [$vfs stat $relative] script {name val} {
            expr {$name in {atime ctime dev gid ino mode mtime nlink size type uid}}
        }]

        Debug.vfs {$self stat DONE: $result}
        return $result
    }

}