Updated 2012-09-28 13:07:44 by LkpPo

20040722 CMcC: A variant of A template virtual filesystem implemented in Snit.

Code included below.

KWIC in mkvfs

Wikit content is built on a metakit view which is like a restricted mkvfs or mk4vfs. It is this which gives Wikit its ability to search for keywords in content and titles (see Wikit in abstract). This facility is also available, for free, in mkvfs. All you have to do is restrict yourself to -nocompress (ie: uncompressed) files. Mk4vfs, which mkvfs is derived from, did not permit per-mount selection of compression, which is one reason I rewrote it.

This facility would be useful in constructing websites, where you get a Search facility essentially for free.

To illustrate this facility, and the utility of making vfs implementations out of Snit, I have added a select and a keyword method:

  • $vfs select {*}$args will return a list of inodes given a metakit select phrase.
  • $vfs keyword $word will return a list of inodes whose contents contain the given word.

I'll add an inode2path method, but it's pretty trivial.

Extension of this kind of functionality to support the other Wikit primitives should be straight forward.

Using SEH's Collating vfs gives you caching for free, similarly with his versioning vfs.

Given a small set of vfs you can assemble quite complex functionality.

NB: the term for free above means for no/little programming effort, and not (of course) for no computational cost.

snitvfs code  edit

# Snit VFS handler

# Usage: vfs $name VFSType ...

# From http://wiki.tcl.tk/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