}
set dll [file join $dir $dll[info sharedlibextension]]
-proc loadvfs {dir dll} {
+proc ::vfs::loadvfs {dir dll} {
global auto_path
if {[lsearch -exact $auto_path $dir] == -1} {
lappend auto_path $dir
load $dll
}
-package ifneeded vfs 1.3.0 [list loadvfs $dir $dll]
+package ifneeded vfs 1.3.0 [list ::vfs::loadvfs $dir $dll]
package ifneeded starkit 1.3.1 [list source [file join $dir starkit.tcl]]
package ifneeded vfslib 1.3.1 [list source [file join $dir vfslib.tcl]]
package ifneeded vfs::zip 1.0 [list source [file join $dir zipvfs.tcl]]
package ifneeded vfs::tk 0.5 [list source [file join $dir tkvfs.tcl]]
-# Virtual filesystems based on the template vfs:
-package ifneeded vfs::template::collate 1.0 [list source [file join $dir template collatevfs.tcl]]
-package ifneeded vfs::template::version 1.0 [list source [file join $dir template versionvfs.tcl]]
-package ifneeded vfs::template::version::delta 1.0 [list source [file join $dir template deltavfs.tcl]]
-package ifneeded vfs::template::fish 1.0 [list source [file join $dir template fishvfs.tcl]]
-package ifneeded vfs::template::quota 1.0 [list source [file join $dir template quotavfs.tcl]]
-package ifneeded vfs::template 1.0 [list source [file join $dir template templatevfs.tcl]]
-
-package ifneeded globfind 1.0 [list source [file join $dir template globfind.tcl]]
-package ifneeded trsync 1.0 [list source [file join $dir template tdelta.tcl]]
--- /dev/null
+#/usr/bin/env tclsh
+
+if 0 {
+########################
+
+chrootvfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.5
+
+A chroot virtual filesystem.
+
+This virual filesystem has an effect similar to a "chroot" command; it makes the named existing directory appear
+to be the top of the filesystem and makes the rest of the real filesystem invisible.
+
+This vfs does not block access by the "exec" command to the real filesystem outside the chroot directory,
+or that of the "open" command when its command pipeline syntax is used.
+
+At the end of this file is example code showing one way to set up a safe slave interpreter suitable for
+running a process safely with limited filesystem access: its file access commands are re-enabled, the exec
+command remains disabled, the open command is aliased so that it can only open files and can't spawn new
+processes, and mounted volumes besides the volume on which the chroot directory resides are aliased so
+that they act as mirrors of the chroot directory.
+
+Such an interpreter should be advantageous for applications such as a web server: which requires some
+filesystem access but presents security threats that make access limitations desirable.
+
+ Install: This code requires the vfs::template package included in the Tclvfs distribution.
+
+ Usage: mount ?-volume? <existing "chroot" directory> <virtual directory>
+
+ examples:
+
+ mount $::env(HOME) /
+
+ mount {C:\My Music} C:/
+
+ mount -volume /var/www/htdocs chroot://
+
+########################
+}
+
+namespace eval ::vfs::template::chroot {
+
+package require vfs::template 1.5
+
+# read template procedures into current namespace. Do not edit:
+foreach templateProc [namespace eval ::vfs::template {info procs}] {
+ set infoArgs [info args ::vfs::template::$templateProc]
+ set infoBody [info body ::vfs::template::$templateProc]
+ proc $templateProc $infoArgs $infoBody
+}
+
+proc file_attributes {file {attribute {}} args} {eval file attributes \$file $attribute $args}
+
+catch {rename redirect_handler {}}
+catch {rename handler redirect_handler}
+
+proc handler args {
+ set path [lindex $args 0]
+ set to [lindex $args 2]
+ set volume [lindex $::vfs::template::mount($to) 1]
+ if {$volume != "-volume"} {set volume {}}
+ set startDir [pwd]
+
+ ::vfs::filesystem unmount $to
+
+ set err [catch {set rv [uplevel ::vfs::template::chroot::redirect_handler $args]} result] ; set errorCode $::errorCode
+
+ eval ::vfs::filesystem mount $volume [list $to] \[list [namespace current]::handler \[file normalize \$path\]\]
+ if {[pwd] != $startDir} {catch {cd $startDir}}
+ if {$err && ([lindex $errorCode 0] == "POSIX")} {vfs::filesystem posixerror $::vfs::posix([lindex $errorCode 1])}
+ if $err {return -code $err $result}
+ return $rv
+}
+
+
+# Example code to set up a safe interpreter with limited filesystem access:
+proc chroot_slave {} {
+ file mkdir /tmp
+ package require vfs::template
+ ::vfs::template::chroot::mount -volume /tmp C:/
+ set vols [lsort -unique [file volumes]]
+ foreach vol $vols {
+ if {$vol == "C:/"} {continue}
+ ::vfs::template::mount C:/ $vol
+ }
+ set slave [interp create -safe]
+ $slave expose cd
+ $slave expose encoding
+ $slave expose fconfigure
+ $slave expose file
+ $slave expose glob
+ $slave expose load
+ $slave expose pwd
+ $slave expose socket
+ $slave expose source
+
+ $slave alias exit exit_safe $slave
+ $slave alias open open_safe $slave
+
+ interp share {} stdin $slave
+ interp share {} stdout $slave
+ interp share {} stderr $slave
+}
+
+proc exit_safe {slave} {
+ interp delete $slave
+}
+
+proc open_safe {args} {
+ set slave [lindex $args 0]
+ set handle [lindex $args 1]
+ set args [lrange $args 1 end]
+ if {[string index $handle 0] != "|"} {
+ eval [eval list interp invokehidden $slave open $args]
+ } else {
+ error "permission denied"
+ }
+}
+
+
+}
+# end namespace ::vfs::template::chroot
+
Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
License: Tcl license
-Version 1.0
+Version 1.5
A collate/broadcast/collect/catchup virtual filesystem. Requires the template vfs in templatevfs.tcl.
a catchup queue. With each subsequent write action, the queue is examined, and if any directory has
become available, the action is performed, allowing offline directories to "catch up."
-Usage: Mount ?-read <directories> -write <directories> -collect <directories> -catchup <directories>? <virtual directory>
+Usage: mount ?-read <directories> -write <directories> -collect <directories> -catchup <directories>? <virtual directory>
Each pathname in <directories> is meant to stand individually, the <directories> symbol is not meant to indicate a
Tcl list. The sets of specified locations are independent; they can overlap or not as desired. Note each
-write
When an individual file is opened for writing, each of the directories specified is searched in
-order for the file; the first file found with the appropriate name is opened. When the file is closed, a
-copy of it is distributed to each specified write directory.
+order for the file; the first file found with the appropriate name is opened. If the file doesn't exist,
+it is created in the first specified write location. When the file is closed, a copy of it is distributed to
+each specified write directory.
-collect
Auto-generates one or more file caches; a copy of any file opened for reading or writing in any of the above
The hard drive can be specified as the single write location, and no writes to the CD-ROM or
ftp site will ever be attempted:
-Mount -read C:/install/package/docs CDROM:/package/docs FTP:/pub/releases/package/docs -write C:/install/package/docs C:/collate/docs
+mount -read C:/install/package/docs CDROM:/package/docs FTP:/pub/releases/package/docs -write C:/install/package/docs C:/collate/docs
Example collect location use: specify a single hard drive location as a read and collect directory.
collect directory; the local copies are accessed first on subsequent reads: hence the collect
specification produces a self-generating local cache:
-Mount -read C:/install/package/images FTP:/pub/releases/package/images -collect C:/install/package/images C:/collate/images
+mount -read C:/install/package/images FTP:/pub/releases/package/images -collect C:/install/package/images C:/collate/images
########################
}
-package provide vfs::template::collate 1.0
-
-package require vfs::template
+package require vfs::template 1.5
namespace eval ::vfs::template::collate {
return
}
set returnValue [eval file attributes \$file $attribute $args]
- if {($relative == {}) && ($attribute == {})} {append returnValue " [list -read $::vfs::template::collate::read($root) -write $::vfs::template::collate::write($root) -collect $::vfs::template::collate::collect($root) -catchup $::vfs::template::collate::catchupstore($root)]"}
+ if {($relative == {}) && ($attribute == {})} {set returnValue [concat $returnValue [list -read $::vfs::template::collate::read($root) -write $::vfs::template::collate::write($root) -collect $::vfs::template::collate::collect($root) -catchup $::vfs::template::collate::catchupstore($root)]]}
return $returnValue
}
proc file_delete {file} {
set newFiles {}
foreach path $::vfs::template::collate::read($root) {
if ![file exists $path] {continue}
- append allFiles " [glob -directory [file join $path $relative] -nocomplain -tails -types $typeString -- $pattern]"
+ set allFiles [concat $allFiles [glob -directory [file join $path $relative] -nocomplain -tails -types $typeString -- $pattern]]
}
set allFiles [lsort -unique $allFiles]
return $allFiles
append newCatchup "[list $action $path $rel]\n" ; continue
}
if ![file exists $source] {continue}
+ file mkdir [file dirname $target]
file copy -force -- $source $target
}
delete {
}
# end namespace ::vfs::template::collate
-
Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
License: Tcl license
-Version 1.0
+Version 1.5
A delta virtual filesystem. Requires the template vfs in templatevfs.tcl.
invisibly generate and manage deltas of the separate versions to save space.
-Usage: Mount <existing directory> <virtual directory>
+Usage: mount <existing directory> <virtual directory>
The delta vfs inherits the -cache and -volume options of the template vfs.
########################
}
-package provide vfs::template::version::delta 1.0
-
-package require vfs::template
+package require vfs::template 1.5
namespace eval ::vfs::template::version::delta {
Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
License: Tcl license
- Version 1.0
+ Version 1.5
- Usage: Mount ?-volume? \
+ Usage: mount ?-volume? \
?-cache <number>? \ # cache retention seconds
?-exec? \ # location of executable
?-transport <protocol>? \ # can be ssh, rsh or plink
Examples:
- Mount -transport ssh -user root -host tcl.tk / /mnt/vfs/tcl
+ mount -transport ssh -user root -host tcl.tk / /mnt/vfs/tcl
- Mount -volume /home/foo rsh://foo@localcomp
+ mount -volume /home/foo rsh://foo@localcomp
- Mount -volume -password foopass /home/foo plink://foo@bar.org:2323/remotemount
+ mount -volume -password foopass /home/foo plink://foo@bar.org:2323/remotemount
- Mount -cache 60 -transport plink -user foo -password foopass -host bar.org /home/foo C:/Tcl/mount/foo
+ mount -cache 60 -transport plink -user foo -password foopass -host bar.org /home/foo C:/Tcl/mount/foo
Client configuration:
########################
}
-package provide vfs::template::fish 1.0
-
-package require vfs::template
+package require vfs::template 1.5
namespace eval ::vfs::template::fish {
Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
License: Tcl license
-Version 1.0
+Version 1.5
The proc globfind is a replacement for tcllib's fileutil::find
-Usage: globfind ?basedir ?filtercmd??
+Usage: globfind ?basedir ?filtercmd? ?switches??
Options:
appended to filtercmd and the result will be evaluated. The evaluation should return
0 or 1; only files whose return code is 1 will be included in the final return result.
+switches - The switches will "prefilter" the results before the filtercmd is applied. The
+available switches are:
+
+ -depth - sets the number of levels down from the basedir into which the
+ filesystem hierarchy will be searched. A value of zero is interpreted
+ as infinite depth.
+
+ -pattern - a glob-style filename-matching wildcard. ex: -pattern *.pdf
+
+ -types - any value acceptable to the "types" switch of the glob command.
+ ex: -types {d hidden}
+
+Side effects:
+
+If somewhere within the search space a directory is a link to another directory within
+the search space, then the variable ::globfind::REDUNDANCY will be set to 1 (otherwise
+it will be set to 0). The name of the redundant directory will be appended to the
+variable ::globfind::redundant_files. This may be used to help track down and eliminate
+infinitely looping links in the search space.
+
+Unlike fileutil::find, the name of the basedir will be included in the results if it fits
+the prefilter and filtercmd criteria (thus emulating the behavior of the standard Unix
+GNU find utility).
+
----
-The proc fileutil::find is useful, but it has several deficiencies:
-
- * On Windows, hidden files are mishandled.
- * On Windows, checks to avoid infinite loops due to nested
- symbolic links are not done.
- * On Unix, nested loop checking requires a "file stat" of each
- file/dir encountered, a significant performance hit.
- * The basedir from which the search starts is not included in the
- results, as it is with GNU find.
- * If the basedir is a file, it is returned in the result not as a
- list element (like glob) but as a string.
- * The proc calls itself recursively, and thus risks running into
- interp recursion limits for very large systems.
- * fileutil.tcl contains three separate instantiations of proc
- find for varying os's/versions. Maintenance nightmare.
-
-The proc globfind eliminates all the above deficiencies. It checks for
-nested symbolic links in a platform-independent way, and scans
-directory hierarchies without recursion.
-
-For speed and simplicity, it takes advantage of glob's ability to use
-multiple patterns to scan deeply into a directory structure in a single
-command, hence the name. Its calling syntax is the same as fileutil::find,
-so with a name change it could be used as a drop-in replacement:
+globfind is designed as a fast and simple alternative to fileutil::find. It takes
+advantage of glob's ability to use multiple patterns to scan deeply into a directory
+structure in a single command, hence the name.
+
+It reports symbolic links along with other files by default, but checks for nesting of
+links which might otherwise lead to infinite search loops. It reports hidden files by
+default unless the -types switch is used to specify exactly what is wanted.
+
+globfind may be used with Tcl versions earlier than 8.4, but emulation of missing
+features of the glob command in those versions will result in slower performance.
+
+globfind is generally two to three times faster than fileutil::find, and fractionally
+faster than perl's File::Find function for comparable searches.
+
+The filtercmd may be omitted if only prefiltering is desired; in this case it may be a
+bit faster to use the proc globtraverse, which uses the same basedir value and
+command-line switches as globfind, but does not take a filtercmd value.
+
+If one wanted to search for pdf files for example, one could use the command:
+
+ globfind $basedir {string match -nocase *.pdf}
+
+It would, however, in this case be much faster to use:
+
+ globtraverse $basedir -pattern *.pdf
########################
}
-package provide globfind 1.0
+package provide fileutil::globfind 1.5
-namespace eval ::globfind {
+namespace eval ::fileutil::globfind {
-proc globfind {{basedir .} {filtercmd {}}} {
- set depth 16
- set filt [string length $filtercmd]
+namespace export globfind globtraverse
+
+proc globfind {{basedir .} {filtercmd {}} args} {
+ set returnFiles {}
+ set types {}
set basedir [file normalize $basedir]
- file stat $basedir fs
- set linkName $basedir
- while {$fs(type) == "link"} {
- if [catch {file stat [set linkName [file normalize [file link $linkName]]] fs}] {break}
- }
- if {$fs(type) == "file"} {
- set filename $basedir
- if {!$filt || [uplevel $filtercmd [list $filename]]} {
- return [list $filename]
- }
- }
- set globPatternTotal {}
- set globPattern *
- set incrPattern /*
- for {set i 0} {$i < $depth} {incr i} {
- lappend globPatternTotal $globPattern
- append globPattern $incrPattern
+
+ # account for possibility that filtercmd is missing by
+ # reformatting $args variable:
+ set args [concat [list $filtercmd] $args]
+ if [expr fmod([llength $args],2)] {
+ set filtercmd [lindex $args 0]
+ set args [lrange $args 1 end]
+ } else {
+ set filtercmd {}
}
- lappend checkDirs $basedir
- set returnFiles {}
- set redo 0
- set terminate 0
- set hidden {}
- while {!$terminate} {
- set currentDir [lindex $checkDirs 0]
- if !$redo {set allFiles [eval glob -directory [list $currentDir] -nocomplain $hidden $globPatternTotal]}
- set redo 0
- set termFile [lindex $allFiles end]
- set termFile [lrange [file split $termFile] [llength [file split $currentDir]] end]
- if {$hidden != {}} {
- set checkDirs [lrange $checkDirs 1 end]
- }
- foreach test {checkdirs length duplicate recursion prune} {
- switch $test {
- checkdirs {
- set afIndex [llength $allFiles]
- incr afIndex -1
- for {set i $afIndex} {$i >= 0} {incr i -1} {
- set cdir [lindex $allFiles $i]
- if {[llength [lrange [file split $cdir] [llength [file split $currentDir]] end]] < $depth} {break}
- file stat $cdir fs
- set linkName $cdir
- while {$fs(type) == "link"} {
- if [catch {file stat [set linkName [file normalize [file link $linkName]]] fs}] {break}
- }
- if {$fs(type) == "directory"} {lappend checkDirs $cdir}
- }
- }
- length {
- if {[llength $termFile] < $depth} {break}
- }
- duplicate {
- set recurseTest 0
- set dupFile [lindex $allFiles end]
- set dupFile [lrange [file split $dupFile] [llength [file split $basedir]] end]
- set dupFileEndDir [expr [llength $dupFile] - 2]
- if {[lsearch $dupFile [lindex $dupFile end-1]] < $dupFileEndDir} {
- set recurseTest 1
- }
- }
- recursion {
- if !$recurseTest {continue}
- if {($hidden == {})} {set type "-types l"} else {set type "-types [list "hidden l"]"}
-
- set linkFiles {}
- set linkDir $currentDir
- while 1 {
- set linkFiles [concat $linkFiles [eval glob -directory [list $linkDir] -nocomplain $type $globPatternTotal]]
- if {$linkDir == $basedir} {break}
- set linkDir [file dirname $linkDir]
- }
- array unset links
- set linkFiles [lsort -unique $linkFiles]
- foreach lf $linkFiles {
- set ltarget [file normalize [file readlink $lf]]
- if {[array names links -exact $ltarget] != {}} {
- lappend pruneLinks $lf
- set redo 1
- }
- array set links "$ltarget $lf"
- }
- }
- prune {
- if ![info exists pruneLinks] {continue}
- set afIndex [llength $allFiles]
- incr afIndex -1
- set cdIndex [llength $checkDirs]
- incr cdIndex -1
- set rfIndex [llength $returnFiles]
- incr rfIndex -1
- foreach pl $pruneLinks {
- for {set i $afIndex} {$i >= 0} {incr i -1} {
- set af [lindex $allFiles $i]
- if ![string first $pl/ $af] {set allFiles [lreplace $allFiles $i $i]}
- }
- for {set i $cdIndex} {$i >= 0} {incr i -1} {
- set cd [lindex $checkDirs $i]
- if ![string first $pl/ $cd] {set checkDirs [lreplace $checkDirs $i $i]}
- }
- for {set i $rfIndex} {$i >= 0} {incr i -1} {
- set rf [lindex $returnFiles $i]
- if ![string first $pl/ $rf] {set returnFiles [lreplace $returnFiles $i $i]}
- }
- }
- unset pruneLinks
+ set filt [string length $filtercmd]
+ set 83ok [package vsatisfies [package present Tcl] 8.3]
+
+ # process command-line switches:
+ foreach {flag value} $args {
+ if {[string first $flag -types] >= 0} {set flag "-types"}
+ if {[string first $flag -pattern] >= 0} {set flag "-pattern"}
+ if {[string first $flag -depth] >= 0} {set flag "-depth"}
+
+ switch -- $flag {
+ -types {
+ set types [list $value]
+
+ # can't use -types pre-8.3, because it doesn't exist in glob command.
+ # thus if it is specified, error out:
+ if !$83ok {error {error: "-types" flag not supported in version 8.2 and earlier}}
+
+ # bug in 8.3, if -types {hidden f} is used, possible crash. So disallow:
+ if {(![package vcompare [package present Tcl] 8.3]) && ($tcl_platform(platform) == "unix") && ([lsearch $types "hidden"] >= 0) && ([lsearch $types "f"] >= 0)} {
+ error {Tcl 8.3 bug: potential program crash if "-types {hidden f}" used}
}
- default {}
+
+ set types "-types $types"
}
+ -pattern {set pattern [list $value]}
+ -depth {set depth [expr [list $value]]}
+ default {error "$flag: incorrect flag value"}
+ }
+ }
+
+ # add basedir to result if it satisfies prefilter conditions:
+ set returnFiles [eval [eval list globtraverse [list [file dirname $basedir]] $args -depth 1]]
+ if {[lsearch -exact $returnFiles $basedir] >= 0} {set returnFiles [list $basedir]} else {set returnFiles {}}
+ # get all files in basedir that satisfy prefilter conditions:
+ set returnFiles [concat $returnFiles [eval [eval list globtraverse \$basedir $args]]]
+
+ # get hidden files if no specific types requested:
+ if {$types == {}} {
+
+ # save redundant file values already gathered:
+ set redundant_files {}
+ if [set REDUNDANCY $[namespace current]::REDUNDANCY] {
+ set redundant_files $[namespace current]::redundant_files
}
- if $redo continue
- if {$hidden == {}} {
- set hidden "-types hidden"
+
+ # get hidden files:
+ set returnFiles [concat $returnFiles [eval [eval list globtraverse \$basedir $args -type hidden]]]
+
+ # virtual filesystems ignore hidden tag, so just in case, filter out duplicates:
+ set returnFiles [lsort -unique $returnFiles]
+
+ # collate redundant file info:
+ if $[namespace current]::REDUNDANCY {
+ set [namespace current]::redundant_files [concat $[namespace current]::redundant_files $redundant_files]
} else {
- set hidden {}
- if {[llength $checkDirs] == 0} {set terminate 1}
+ set [namespace current]::redundant_files $redundant_files
}
- set returnFiles [concat $returnFiles $allFiles]
+ set [namespace current]::REDUNDANCY [expr ($[namespace current]::REDUNDANCY || $REDUNDANCY)]
}
- set filterFiles {}
- foreach filename [lsort -unique [linsert $returnFiles end $basedir]] {
- if {!$filt || [uplevel $filtercmd [list $filename]]} {
- lappend filterFiles $filename
+
+ # apply filtercmd to prefiltered results if one is specified:
+ if $filt {
+ set filterFiles {}
+ foreach filename $returnFiles {
+ if [uplevel $filtercmd [list $filename]] {
+ lappend filterFiles $filename
+ }
}
+ } else {
+ set filterFiles $returnFiles
}
+
return $filterFiles
}
-# scfind: a command suitable for use as a filtercmd with globfind, arguments
-# duplicate a subset of GNU find args.
-
-proc scfind {args} {
- set filename [file join [pwd] [lindex $args end]]
- set switches [lrange $args 0 end-1]
-
- array set types {
- f file
- d directory
- c characterSpecial
- b blockSpecial
- p fifo
- l link
- s socket
- }
+proc globtraverse {{basedir .} args} {
+ set [namespace current]::REDUNDANCY 0
+ unset -nocomplain [namespace current]::redundant_files
+ set depth 0
- array set signs {
- - <
- + >
- }
+ # search 16 directory levels per iteration, glob can't handle more patterns than that at once.
+ set maxDepth 16
+
+ set pattern *
+ set types {}
+ set resultList {}
+
+ set basedir [file normalize $basedir]
+ if ![file isdirectory $basedir] {return}
+
+ set baseDepth [llength [file split $basedir]] ; # calculate starting depth
+
+ lappend checkDirs $basedir ; # initialize list of dirs to check
+
+ # format basedir variable for later infinite loop checking:
+ set basedir $basedir/
+ set basedir [string map {// /} $basedir]
- array set multiplier {
- time 86400
- min 3600
+ set 83ok [package vsatisfies [package present Tcl] 8.3]
+
+ # process command-line switches:
+ foreach {flag value} $args {
+ if {[string first $flag -types] >= 0} {set flag "-types"}
+ if {[string first $flag -pattern] >= 0} {set flag "-pattern"}
+ if {[string first $flag -depth] >= 0} {set flag "-depth"}
+
+ switch -- $flag {
+ -types {
+ set types [list $value]
+ if !$83ok {error {error: "-types" flag not supported in version 8.2 and earlier}}
+ if {(![package vcompare [package present Tcl] 8.3]) && ($tcl_platform(platform) == "unix") && ([lsearch $types "hidden"] >= 0) && ([lsearch $types "f"] >= 0)} {
+ error {Tcl 8.3 bug: potential program crash if "-types {hidden f}" used}
+ }
+ set types "-types $types"
+ }
+ -pattern {set pattern [list $value]}
+ -depth {set depth [expr [list $value]]}
+ default {error "$flag: incorrect flag value"}
+ }
}
- file stat $filename fs
- set pass 1
- set switchLength [llength $switches]
- for {set i 0} {$i < $switchLength} {incr i} {
- set sw [lindex $switches $i]
- switch -- $sw {
- -type {
- set value [lindex $switches [incr i]]
- if ![string equal $fs(type) $types($value)] {return 0}
+
+ # Main result-gathering loop:
+ while {[llength $checkDirs]} {
+ set currentDir [lindex $checkDirs 0]
+
+ set currentDepth [expr [llength [file split $currentDir]] - $baseDepth] ; # distance from start depth
+
+ set searchDepth [expr $depth - $currentDepth] ; # distance from max depth to search to
+
+ # build multi-pattern argument to feed to glob command:
+ set globPatternTotal {}
+ set globPattern *
+ set incrPattern /*
+ for {set i 1} {$i <= $maxDepth} {incr i} {
+ set customPattern [string range $globPattern 0 end-1]
+ append customPattern $pattern
+ lappend globPatternTotal $customPattern
+ append globPattern $incrPattern
+ incr searchDepth -1
+ if {$searchDepth == 0} {break}
+ }
+
+ # save pattern to use for iterative dir search later:
+ set dirPattern [string range $globPattern 0 end-2]
+
+ # glob pre-8.3 doesn't support -directory switch; emulate it if necessary:
+ if $83ok {
+ set contents [eval glob -nocomplain -directory \$currentDir $types -- $globPatternTotal]
+ } else {
+ set wd [pwd]
+ set newContents {}
+ cd $currentDir
+ if [catch {set contents [eval glob -nocomplain -- $globPatternTotal]} err] {
+ cd $wd
+ error $err
}
- -regex {
- set value [lindex $switches [incr i]]
- if ![regexp $value $filename] {return 0}
+ cd $wd
+ foreach item $contents {
+ set item [file join $currentDir $item]
+ lappend newContents $item
}
- -size {
- set value [lindex $switches [incr i]]
- set sign "=="
- if [info exists signs([string index $value 0])] {
- set sign $signs([string index $value 0])
- set value [string range $value 1 end]
- }
- set sizetype [string index $value end]
- set value [string range $value 0 end-1]
- if [string equal $sizetype b] {set value [expr $value * 512]}
- if [string equal $sizetype k] {set value [expr $value * 1024]}
- if [string equal $sizetype w] {set value [expr $value * 2]}
+ set contents $newContents
+ unset newContents
+ }
+ set resultList [concat $resultList $contents]
+
+ # check if iterative dir search is necessary (if specified depth not yet reached):
+ set contents {}
+ set findDirs 1
+ if {([expr $currentDepth + [llength [file split $dirPattern]]] >= $depth) && ($depth > 0)} {set findDirs 0}
- if ![expr $fs(size) $sign $value] {return 0}
+ # find dirs at current depth boundary to prime iterative search.
+ # Pre-8.3 glob doesn't support -type or -dir switches; emulate if necessary:
+ if {$83ok && $findDirs} {
+ set contents [glob -nocomplain -directory $currentDir -type d -- $dirPattern]
+ } elseif $findDirs {
+ set wd [pwd]
+ set newContents {}
+ cd $currentDir
+ if [catch {set contents [glob -nocomplain -- $dirPattern/]} err] {
+ cd $wd
+ error $err
}
- -atime -
- -mtime -
- -ctime -
- -amin -
- -mmin -
- -cmin {
- set value [lindex $switches [incr i]]
-
- set sw [string range $sw 1 end]
- set time [string index $sw 0]
- set interval [string range $sw 1 end]
- set sign "=="
- if [info exists signs([string index $value 0])] {
- set sign $signs([string index $value 0])
- set value [string range $value 1 end]
- }
- set value [expr [clock seconds] - ($value * $multiplier($interval))]
- if ![expr $value $sign $fs($sw)] {return 0}
+ cd $wd
+ foreach item $contents {
+ set item [file join $currentDir [string range $item 0 end-1]]
+ lappend newContents $item
}
- }
- }
- return 1
-}
+ set contents $newContents
+ unset newContents
+ }
-# find: example use of globfind and scfind to duplicate a subset of the
-# command line interface of GNU find.
-proc find {args} {
- globfind [lindex $args 0] [list [subst "scfind $args"]]
-}
+ # check for redundant links in dir list:
+ set contentLength [llength $contents]
+ set i 0
+ while {$i < $contentLength} {
+ set item [lindex $contents end-$i]
+ incr i
+
+ # kludge to fully resolve link to native name:
+ set linkValue [file dirname [file normalize [file join $item __dummy__]]]
+
+ # if item is a link, and native name is already in the search space, skip it:
+ if {($linkValue != $item) && (![string first $basedir $linkValue])} {
+ set [namespace current]::REDUNDANCY 1
+ lappend [namespace current]::redundant_files $item
+ continue
+ }
+
+ lappend checkDirs $item
+ }
-namespace export -clear globfind
+ # remove current search dir from search list to prime for next iteration:
+ set checkDirs [lrange $checkDirs 1 end]
+ }
+ return $resultList
+}
+# Tcl pre-8.4 lacks [file normalize] command; emulate it if necessary:
+proc ::fileutil::globfind::file {args} {
+ if {[lindex $args 0] == "normalize"} {
+ set filename [lindex $args 1]
+ set tail [file tail $filename]
+ set filename [::fileutil::fullnormalize [file dirname $filename]]
+ set filename [file join $filename $tail]
+ return $filename
+ } else {
+ return [uplevel ::file $args]
+ }
}
-# end namespace globfind
+# Eliminate emulation of [file normalize] if version 8.4 or better:
+if [package vsatisfies [package present Tcl] 8.4] {
+ rename ::fileutil::globfind::file {}
+} else {
+ package require fileutil 1.13
+}
+}
+# end namespace ::fileutil::globfind
--- /dev/null
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex -lazy" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded vfs::template 1.5 [list source [file join $dir templatevfs.tcl]]
+
+set ::auto_index(::vfs::template::mount) [list package require vfs::template 1.5]
+set ::auto_index(::vfs::template::collate::mount) [list source [file join $dir collatevfs.tcl]]
+set ::auto_index(::vfs::template::quota::mount) [list source [file join $dir quotavfs.tcl]]
+set ::auto_index(::vfs::template::version::mount) [list source [file join $dir versionvfs.tcl]]
+set ::auto_index(::vfs::template::version::delta::mount) [list source [file join $dir deltavfs.tcl]]
+set ::auto_index(::vfs::template::chroot::mount) [list source [file join $dir chrootvfs.tcl]]
+set ::auto_index(::vfs::template::fish::mount) [list source [file join $dir fishvfs.tcl]]
+
+package ifneeded fileutil::globfind 1.5 [list source [file join $dir globfind.tcl]]
+package ifneeded trsync 1.0 [list source [file join $dir tdelta.tcl]]
+
Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
License: Tcl license
-Version 1.0
+Version 1.5
A quota-enforcing virtual filesystem. Requires the template vfs in templatevfs.tcl.
the oldest access times that contribute to the quota are deleted until there is room within
the quota limit for the addition of the new file.
-The exception is if the file's attributes are large enough to violate the quota by itself, it is barred
-without first deleting all other files contributing to the quota.
+The exception for the running total variety is if the file's attribute is large enough to
+exceed the quota by itself, it is barred without first deleting all other files contributing to
+the quota.
At mount time, all files in the existing directory are examined and quotas calculated. Files may be
deleted to keep quotas under their defined limits. After mount, when a new file is moved into the
virtual directory or an existing file edited, its properties are examined with respect to the defined
quotas; if no room can be made for it, the move or edit is rejected.
-Usage: Mount <quota group> ?<quota group>... ? <existing directory> <virtual directory>
+Usage: mount <quota group> ?<quota group>... ? <existing directory> <virtual directory>
Quota group definition:
Examples -- to set a 10 MB size limit on your ftp upload directory:
-Mount -size -total 10000000 C:/temp/upload C:/vfs/ftp/pub
+mount -size -total 10000000 C:/temp/upload C:/vfs/ftp/pub
To allow only PNG or JPEG files in a photo collection:
-Mount -filename {!*.png !*.jpg !*.jpeg} -quota 0 /home/shuntley/photos /vfs/photo
+mount -filename {!*.png !*.jpg !*.jpeg} -quota 0 /home/shuntley/photos /vfs/photo
To ban GIF files from your web site images subdirectory:
-Mount -filename /docroot/images/*.gif -quota 0 {C:/Program Files/Apache/htdocs} /docroot
+mount -filename {C:/Program Files/Apache/htdocs/images/*.gif} -quota 0 {C:/Program Files/Apache/htdocs} /docroot
To disallow creation of subdirectories:
-Mount -type directory -quota 0 /ftp/upload /intake
+mount -type directory -quota 0 /ftp/upload /intake
-To allow only 1 MB of files greater than 10kB in size:
-Mount -size {expr 10000 <} -ruletotal 1000000 /tmp /vfs/dump
+Use a rule to allow only 1 MB of files greater than 10kB in size:
+mount -size {expr 10000 <} -ruletotal 1000000 /tmp /vfs/dump
-To allow only log files and keep only 1 more than one week:
-Mount -filename !*.log -quota 0 -mtime {expr [clock scan {7 days ago}] >} -quota 1 /var/log /vfs/history
+Use two quota groups to allow only log files and keep only 1 more than one week:
+mount -filename !*.log -quota 0 -mtime {expr [clock scan {7 days ago}] >} -quota 1 /var/log /vfs/history
########################
}
-package provide vfs::template::quota 1.0
+package require vfs::template 1.5
-package require vfs::template
-
-package require globfind
+package require fileutil::globfind
namespace eval ::vfs::template::quota {
seek $channel 0 end
set quotaSize [tell $channel]
seek $channel 0
- set filechannel $::vfs::template::quota::channels($channel)
+ set filechannel [lindex $::vfs::template::quota::channels($channel) 0]
+ set newFile [lindex $::vfs::template::quota::channels($channel) 1]
+ unset ::vfs::template::quota::channels($channel)
+ set file [file join $path $relative]
# Check if edited size violates any size quotas before allowing commit:
- if [catch {QuotaAdd [file join $path $relative]}] {close $filechannel ; error "Disk quota exceeded"}
+ if [catch {QuotaAdd $file}] {
+ close $filechannel
+ if $newFile {catch {file delete -force $file}}
+ error "Disk quota exceeded"
+ }
seek $filechannel 0
fcopy $channel $filechannel
close $filechannel
upvar root root
array set quotaArray $::vfs::template::quota::quota($root)
QuotaDelete $file
+ set ::vfs::template::quota::quota($root) [array get quotaArray]
return
}
proc file_executable {file} {file executable $file}
# remove file from quota tallies until channel is closed:
array set quotaArray $::vfs::template::quota::quota($root)
QuotaDelete $file 0
+ set ::vfs::template::quota::quota($root) [array get quotaArray]
# Use memchan to store edits so edit can be rejected if it violates size quotas:
set memchannel [vfs::memchan]
+ fconfigure $channel -translation binary
+ fconfigure $memchannel -translation binary
seek $channel 0
fcopy $channel $memchannel
- set [namespace current]::channels($memchannel) $channel
+ set [namespace current]::channels($memchannel) "$channel $newFile"
return $memchannel
}
# add custom handling for new vfs args here.
- namespace import -force ::globfind::globfind
+ namespace import -force ::fileutil::globfind::globfind
set quotaArgs [lrange $args 0 end-2]
ParseArgs ::vfs::template::quota::quota($to) $quotaArgs
set atime [lindex $aset 0]
set afile [lindex $aset 1]
append atimes " $atime [list $afile]"
+ set ::vfs::template::quota::files($afile) $atime
}
set ::vfs::template::quota::atimes($root) $atimes
# Used as argument to proc globfind to recurse down dir hierarchies and process each file and dir found:
proc QuotaAdd {fileName} {
+ set caller [lindex [info level -1] 0]
+ if {$caller == "MountProcedure"} {set init 1} else {set init 0}
upvar path path root root quotaSize quotaSize
if ![string first ".vfs_" [file tail $fileName]] {return 0}
if {[info exists path] && ($fileName == $path)} {return 0}
set items [lsort -unique [string map {",type " " " ",rule " " " ",quota " " " ",current " " "} " [array names quotaArray] "]]
set delete 1
- file stat $fileName fs
+ set noexist [catch {file stat $fileName fs}]
+ if $noexist {return 0}
set fs(filename) $fileName
# if this call is being used to check edits, replace file size with channel size and don't delete file if edit too big:
- if [info exists quotaSize] {set fs(size) $quotaSize ; set delete 0}
+ if [info exists quotaSize] {set fs(size) $quotaSize ; set delete 0 ; unset quotaSize}
# Update queue which tracks which files to try deleting first to make room for new files:
append ::vfs::template::quota::atimes($root) " $fs(atime) [list $fileName]"
regexp {([0-9]*),(.*)} $item trash groupCount item
if ![info exists fs($item)] {array set fs [file attributes $fileName]}
if ![info exists fs($item)] {continue}
- if [eval $quotaArray($groupCount,$item,rule) [list $fs($item)]] {
+ set contrib [eval $quotaArray($groupCount,$item,rule) [list $fs($item)]]
+ if $contrib {
if {$quotaArray($groupCount,$item,type) == "total"} {
# If file quantity by itself would violate quota, reject immediately:
if {$fs($item) > $quotaArray($groupCount,$item,quota)} {
if $delete {catch {file delete -force -- $fileName} result}
- vfs::filesystem posixerror $::vfs::posix(EDQUOT)
+if [info exists ::vfs::template::quota::debug] {
+puts "\n$fileName violates quota by itself:
+$item: $fs($item)
+quota: $quotaArray($groupCount,$item,quota)"
+if $delete {puts "$fileName deleted: $result"}
+}
+ if $init {return 0} else {vfs::filesystem posixerror $::vfs::posix(EDQUOT)}
}
- set $quotaArray($groupCount,$item,current) [expr $quotaArray($groupCount,$item,current) + $fs($item)]
+ set quotaArray($groupCount,$item,current) [expr $quotaArray($groupCount,$item,current) + $fs($item)]
} else {
- if {$quotaArray($groupCount,$item,quota == 0} {
+ if {$quotaArray($groupCount,$item,quota) == 0} {
if $delete {catch {file delete -force -- $fileName} result}
- vfs::filesystem posixerror $::vfs::posix(EDQUOT)
+if [info exists ::vfs::template::quota::debug] {
+puts "\n$fileName violates quota by itself:
+$item: $fs($item)
+quota: $quotaArray($groupCount,$item,quota)"
+if $delete {puts "$fileName deleted: $result"}
+}
+ if $init {return 0} else {vfs::filesystem posixerror $::vfs::posix(EDQUOT)}
}
incr quotaArray($groupCount,$item,current)
}
if {$quotaArray($groupCount,$item,current) > $quotaArray($groupCount,$item,quota)} {lappend overLimit "$groupCount,$item"}
}
}
-
# if given file puts some quotas over limit, see if room can be made by deleting older files:
+
foreach item $overLimit {
+ set itm [lindex [split $item ,] 1]
if {$quotaArray($item,current) <= $quotaArray($item,quota)} {continue}
-
+
# examine queue of stored atimes to find older files:
foreach {atime afile} $::vfs::template::quota::atimes($root) {
# if stored filename is same as given filename, given filename violates quota and must be rejected:
if {$afile == $fileName} {
+ if !$delete {set quotaSize $fs(size)}
catch {QuotaDelete $fileName $delete}
set ::vfs::template::quota::quota($root) [array get quotaArray]
- vfs::filesystem posixerror $::vfs::posix(EDQUOT)
+ if $init {return 0} else {vfs::filesystem posixerror $::vfs::posix(EDQUOT)}
}
# If stored file contributes to quota, delete it and remove from quota tally:
- if [eval $quotaArray($item,rule) [list $afile]] {
+
+ if {$itm == "filename"} {
+ set itm_val $afile
+ } elseif {[string index $itm 0] == "-"} {
+ set itm_val [file attributes $afile $itm]
+ } else {
+ file stat $afile iv
+ set itm_val $iv($itm)
+ }
+
+ set contrib [eval $quotaArray($item,rule) [list $itm_val]]
+ if $contrib {
+ if {$quotaArray($item,type) == "total"} {
+ set itm [lindex [split $item ,] 1]
+ if {[string index $itm 0] == "-"} {
+ set itm_val [file attributes $afile $itm]
+ } else {
+ file stat $afile iv
+ set itm_val $iv($itm)
+ }
+ if !$itm_val {continue}
+ }
set ::vfs::template::quota::quota($root) [array get quotaArray]
QuotaDelete $afile
}
# Must parse contents twice, eliminate files first, then dirs:
foreach file [concat $files //// $files] {
if {$file == "////"} {set type directory ; continue}
-
+
# cache quantity info to save time on second pass:
if ![info exists stat($file)] {
file stat $file fs
set fs(filename) $fileName
- if [info exists quotaSize] {set fs(size) quotaSize}
+ if [info exists quotaSize] {set fs(size) $quotaSize}
set stat($file) [array get fs]
}
array set fs $stat($file)
# Check each quota to see if current file contributes to it:
foreach item $items {
- regexp {([0-9]*),(.*)} $item trash groupCount item
+ regexp {([0-9]*),(.*)} $item trash groupCount item
if ![info exists fs($item)] {array set fs [file attributes $file] ; set stat($file) [array get fs]}
if ![info exists fs($item)] {continue}
- if [eval $quotaArray($groupCount,$item,rule) [list $file]] {
+ set contrib [eval $quotaArray($groupCount,$item,rule) [list $fs($item)]]
+ if $contrib {
if {$quotaArray($groupCount,$item,type) == "total"} {
- set $quotaArray($groupCount,$item,current) [expr $quotaArray($groupCount,$item,current) - $fs($item)]
+ set quotaArray($groupCount,$item,current) [expr $quotaArray($groupCount,$item,current) - $fs($item)]
} else {
incr quotaArray($groupCount,$item,current) -1
}
+if [info exists ::vfs::template::quota::debug] {
+puts "\n$file contributed to quota:
+rule: $quotaArray($groupCount,$item,rule)
+quota: $quotaArray($groupCount,$item,quota)
+current: $quotaArray($groupCount,$item,current)"
+}
}
}
# After removing file from quota tallies, delete it:
if $delete {file delete -force -- $file}
+if {$delete && [info exists ::vfs::template::quota::debug]} {
+puts "\n$file deleted"
+}
}
return
}
# cast each category into old syntax:
foreach {type pr quota number} $quotas {
set patrul "-pattern"
- if {[lsearch -exact [info commands [lindex $pr 0]] [lindex $pr 0]] > -1} {set patrul "-rule"}
+ if {[lsearch -exact [info commands [string trim [string range $pr 0 [string first { } $pr]]]] [string trim [string range $pr 0 [string first { } $pr]]]] > -1} {
+ set patrul "-rule"
+ }
if ![info exists attrs($type)] {set type [string range $type 1 end]}
append newArgs " -number: -item $type $patrul [list $pr] -quota $number"
}
foreach {type total number} $totals {
if ![info exists attrs($type)] {set type [string range $type 1 end]}
- append newArgs " -total: -item $type $patrul [list $pr] -quota $number"
+ append newArgs " -total: -item $type -quota $number"
}
foreach {type pr rtotal number} $rtotals {
set patrul "-pattern"
- if {[lsearch -exact [info commands [lindex $pr 0]] [lindex $pr 0]] > -1} {set patrul "-rule"}
+ if {[lsearch -exact [info commands [string trim [string range $pr 0 [string first { } $pr]]]] [string trim [string range $pr 0 [string first { } $pr]]]] > -1} {
+ set patrul "-rule"
+ }
if ![info exists attrs($type)] {set type [string range $type 1 end]}
append newArgs " -total: -item $type $patrul [list $pr] -quota $number"
}
}
# end namespace ::vfs::template::quota
-
Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
License: Tcl license
-Version 1.01
+Version 1.5
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
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>
+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 disble caching. This
+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
package require vfs 1.0
-package provide vfs::template 1.0
+# force sourcing of vfsUtils.tcl:
+set vfs::posix(load) x
+vfs::posixError load
+unset vfs::posix(load)
+
+package provide vfs::template 1.5
namespace eval ::vfs::template {
########################
}
-package require vfs::template
+package require vfs::template 1.5
# read template procedures into current namespace. Do not edit:
foreach templateProc [namespace eval ::vfs::template {info procs}] {
namespace eval ::vfs::template {
-proc Mount {args} {
+proc mount {args} {
# handle template command line args:
set volume [lindex $args [lsearch $args "-volume"]]
# ensure files named ".vfs_*" can be opened
set ::vfs::template::vfs_retrieve 1
- # make sure file commands can be called without redirection to vfs procs:
- catch {namespace forget ::vfs::template::overload::*}
-
set pathto [eval MountProcedure $args]
# re-hide ".vfs_*" files
if [string equal $volume {}] {set to [file normalize $to]}
# preserve mount info for later duplication if desired:
- set ::vfs::template::mount($to) "[namespace current]::Mount $volume -cache $cache $args"
+ set ::vfs::template::mount($to) "[namespace current]::mount $volume -cache $cache $args"
# if virtual location still mounted, unmount it by force:
if {[lsearch [::vfs::filesystem info] $to] != -1} {::vfs::filesystem unmount $to}
# register location with Tclvfs package:
eval ::vfs::filesystem mount $volume \$to \[list [namespace current]::handler \$path\]
- ::vfs::RegisterMount $to [list [namespace current]::Unmount]
+ ::vfs::RegisterMount $to [list [namespace current]::unmount]
# ensure close callback background error appears at script execution level:
trace remove execution ::close leave ::vfs::template::CloseTrace
}
# undo Tclvfs API hooks:
-proc Unmount {to} {
+proc unmount {to} {
set to [::file normalize $to]
set path [lindex [::vfs::filesystem info $to] end]
# call custom unmount procedure:
set ::vfs::template::vfs_retrieve 1
- catch {namespace forget ::vfs::template::overload::*}
UnmountProcedure $path $to
unset -nocomplain ::vfs::template::vfs_retrieve
# vfshandler command required by Tclvfs API:
proc handler {path cmd root relative actualpath args} {
# puts [list $path $root $relative $cmd $args [namespace current]]
- # ensure all calls to file commands by handler are redirected to simplified API at top of this script
- catch {namespace import -force ::vfs::template::overload::*}
set fileName [::file join $path $relative]
set virtualName [::file join $root $relative]
return
}
- # if attribute give in args, return its value:
+ # if attribute given in args, return its value:
if ![string equal $index {}] {
return $attributes($attribute)
}
set mode [lindex $args 1]
if [string equal $mode "r"] {return}
# never use real close command here, custom overloaded proc only.
- set err [catch {close $channelID} result]
+ set err [catch {close_ $channelID} result]
if $err {::vfs::template::closeerror $::errorInfo ; error $::errorInfo}
return
}
set recursive [lindex $args 0]
if !$recursive {
if {[MatchInDirectory $path $root $relative $actualpath * 0] != {}} {
- ::vfs::filesystem posixerror $::vfs::posix(ENOTEMPTY)
- return -code error $::vfs::posix(ENOTEMPTY)
+ ::vfs::filesystem posixerror $::vfs::posix(EEXIST)
+ return -code error $::vfs::posix(EEXIST)
}
}
- if {$relative == {}} {Unmount $root ; return}
+ if {$relative == {}} {unmount $root ; return}
RemoveDirectory $path $root $relative $actualpath
CacheClear $virtualName
}
foreach mode $modeString {
set result [CacheGet [namespace current]::$mode $virtualName [set [namespace current]::cache($root)] $secs]
if [string equal $result ""] {
- set result [eval file $mode \$fileName]
+ set result [eval file_$mode \$fileName]
CacheSet [namespace current]::$mode $virtualName $result $secs
}
if !$result {error error}
}
proc CreateDirectory {path root relative actualpath} {
- file mkdir [::file join $path $relative]
+ file_mkdir [::file join $path $relative]
}
proc DeleteFile {path root relative actualpath} {
set fileName [::file join $path $relative]
- file delete -force -- $fileName
+# file delete -force -- $fileName
+ file_delete $fileName
}
proc FileAttributes {path root relative actualpath} {
set fileName [::file join $path $relative]
- return [file attributes $fileName]
+ return [file_attributes $fileName]
}
proc FileAttributesSet {path root relative actualpath attribute value} {
set fileName [::file join $path $relative]
- file attributes $fileName $attribute $value
+ file_attributes $fileName $attribute $value
}
proc MatchInDirectory {path root relative actualpath pattern types} {
set pathName [::file join $path $relative]
# get non-hidden files:
- set globList [glob -directory $pathName -nocomplain -tails -types $typeString -- $pattern]
+ set globList [glob_ -directory $pathName -nocomplain -tails -types $typeString -- $pattern]
# if underlying location is not itself a vfs, get hidden files (Tclvfs doesn't pass "hidden" type to handler)
- if [catch {::vfs::filesystem info $path}] {append globList " [glob -directory $pathName -nocomplain -tails -types "$typeString hidden" -- $pattern]"}
+ if [catch {::vfs::filesystem info $path}] {set globList [concat $globList [glob_ -directory $pathName -nocomplain -tails -types "$typeString hidden" -- $pattern]]}
# convert real path to virtual path:
set newGlobList {}
set fileName [::file join $path $relative]
set newFile 0
if ![file exists $fileName] {set newFile 1}
- set channelID [open $fileName $mode]
- if $newFile {catch {file attributes $fileName -permissions $permissions}}
+ set channelID [open_ $fileName $mode]
+ if $newFile {catch {file_attributes $fileName -permissions $permissions}}
return $channelID
}
proc RemoveDirectory {path root relative actualpath} {
set fileName [::file join $path $relative]
- file delete -force -- $fileName
+# file delete -force -- $fileName
+ file_delete $fileName
}
proc Stat {path root relative actualpath} {
- file stat [::file join $path $relative] fs
+ file_stat [::file join $path $relative] fs
return [array get fs]
}
proc Utime {path root relative actualpath atime mtime} {
set fileName [::file join $path $relative]
- file atime $fileName $atime
- file mtime $fileName $mtime
+ file_atime $fileName $atime
+ file_mtime $fileName $mtime
}
# check value of ::errorInfo to ensure close callback didn't generate background
array set $array [list $fileValue $value]
}
+# map built-in file selection dialogs to pure Tk equivalents, so virtual
+# filesystems can be browsed with same-looking code:
+proc tk_getOpenFile {args} {
+ eval [eval list ::tk::dialog::file:: open $args]
}
-# end namespace eval ::vfs::template
-# Following procs redirect all calls to file commands in Tclvfs API to the simplified API
-# at the top of this script. If one desires to work directly with the Tclvfs API procs
-# instead of the simplified API, delete contents of this namespace, and simplified procs will never be called.
-
-namespace eval ::vfs::template::overload {
-
-proc close {args} {
- uplevel namespace forget ::vfs::template::overload::*
- upvar path path root root relative relative
- set rv [uplevel close_ $args]
- uplevel namespace import -force ::vfs::template::overload::*
- return $rv
+proc tk_getSaveFile {args} {
+ eval [eval list ::tk::dialog::file:: save $args]
}
-proc file {args} {
- uplevel namespace forget ::vfs::template::overload::*
- upvar path path root root relative relative
-
- set option [lindex $args 0]
- set fileName [lindex $args 1]
-
- set rv {}
- switch -- $option {
- atime -
- mtime {
- set time [lindex $args 2]
- set rv [uplevel file_$option [list $fileName] $time]
- }
- attributes {
- set attribute [lindex $args 2]
- set value [lindex $args 3]
- set rv [uplevel file_attributes [list $fileName] [lrange $args 2 3]]
- }
- delete {
- set fileName [lindex $args 3]
- set rv [uplevel file_delete [list $fileName]]
- }
- executable -
- exists -
- mkdir -
- readable -
- writable {
- set rv [uplevel file_$option [list $fileName]]
- }
- stat {
- set arrayName [lindex $args 2]
- uplevel file_stat [list $fileName] $arrayName
- }
- default {
- set rv [uplevel ::file $args]
- }
- }
- uplevel namespace import -force ::vfs::template::overload::*
- return $rv
-}
-
-proc open {args} {
- upvar path path root root relative relative
- uplevel namespace forget ::vfs::template::overload::*
- set rv [uplevel open_ $args]
- uplevel namespace import -force ::vfs::template::overload::*
- return $rv
+proc tk_chooseDirectory {args} {
+ eval [eval list ::tk::dialog::file::chooseDir:: $args]
}
-proc glob {args} {
- upvar path path root root relative relative
- uplevel namespace forget ::vfs::template::overload::*
- set rv [uplevel glob_ $args]
- uplevel namespace import -force ::vfs::template::overload::*
- return $rv
}
-
-namespace export -clear *
-
-}
-# end namespace ::vfs::template::overload
-
+# end namespace eval ::vfs::template
# overload exit command so that all vfs's are explicitly
# unmounted before program termination:
Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
License: Tcl license
-Version 1.03
+Version 1.5
A versioning virtual filesystem. Requires the template vfs in templatevfs.tcl.
Older versions can be retrieved by setting the -project and -time values appropriately.
-Usage: Mount ?-keep <number> -project <list of tags> -time <timestamp or "clock scan" suitable phrase>? <existing directory> <virtual directory>
+Usage: mount ?-keep <number> -project <list of tags> -time <timestamp or "clock scan" suitable phrase>? <existing directory> <virtual directory>
Options:
########################
}
-package provide vfs::template::version 1.0
+package require vfs::template 1.5
-package require vfs::template
-
-package require globfind
-namespace import -force ::globfind::globfind
+package require fileutil::globfind
namespace eval ::vfs::template::version {
# add custom handling for new vfs args here.
+ namespace import -force ::fileutil::globfind::globfind
+
set argsLength [llength $args]
for {set i 0} {$i < $argsLength} {incr i} {
switch -- [lindex $args $i] {
::md5::md5 -hex -- [read $channel]
}
-# figure out if time is a string, milliseconds or seconds count, return seconds cound
+# figure out if time is a string, milliseconds or seconds count, return seconds count
proc SetTime {time} {
if ![string is digit -strict $time] {catch {set time [clock scan $time]}}
if ![string is digit -strict $time] {error "invalid time value."}
projects / tclvfs / commitdiff