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 ** ====== # 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 } } ====== !!!!!! %|[Category VFS] | [Category Snit]|% !!!!!!