[SEH] A quota-enforcing virtual filesystem. Quotas can be set on any value returned by [[file stat]] or [[file attributes]], plus the special values filename and dirname. Two types of quota limits can be set: total and number. A total quota can be set on a numerical value like 'size' and enforces a limit on the sum of all values of all files. A number quota can be set on any value, and enforces a limit on the number of files whose given attribute matches a pattern or rule. By default the quota applies to the whole mounted location, but separate sub-locations can be specified. Unlimited multiple quotas can be defined for separate values, types and locations. Each quota is set with a quota group: -number: -item -pattern |-rule -quota [[-location ]] -total: -item -quota [[-location ]] The string containing all quota groups is incorporated into the Mount command. If a file add leads to a quota being exceeded, the oldest files matching the quota criterion are deleted until the quota limit is re-established. Usage: Mount Examples: to set a 10 MB size limit on your ftp upload directory Mount C:/temp/upload -total: -item size -quota 10000000 /ftp/pub To ban GIF files from your web site images directory Mount C:/Apache/htdocs -number: -item filename -pattern "*.gif *GIF" -quota 0 -location images /docroot To exclude all files which are not members of the Unix group called "admin" and delete files created longer that a week ago First create a procedure to act as a rule: proc ccheck {value} {if {$value < [clock scan "7 days ago"]} {return 1} else {return 0}} Mount /var/logs -number: -item -group -pattern !admin -quota 0 -number: -item ctime -rule ccheck -quota 0 /reports (the pattern is glob-style with the optional addition of ! at the beginning to indicate negative match) Note that you can create a self-generating local cache with [a collate/broadcast virtual filesystem], when daisy-chained with this VFS, you can restrict the cache size, among other things. Based on [a template virtual filesystem] I haven't done much testing on this or other virtual filesystems, I'm trying to post new ideas rapidly in order to stimulate interest and discussion. I will go back and polish up my work. package require vfs 1 namespace eval ::vfs::template {} proc ::vfs::template::quota::Mount {args} { set pathto [eval MountProcedure $args] set path [lindex $pathto 0] set to [lindex $pathto 1] ::vfs::filesystem mount $to [list ::vfs::template::quota::handler $path] ::vfs::RegisterMount $to [list ::vfs::template::quota::Unmount] return $to } proc ::vfs::template::quota::Unmount {to} { set path [lindex [::vfs::filesystem info $to] end] UnmountProcedure $path $to ::vfs::filesystem unmount $to } proc ::vfs::template::quota::handler {path cmd root relative actualpath args} { switch -- $cmd { access { set mode [lindex $args 0] set error [catch {Access $path $root $relative $actualpath $mode}] if $error {vfs::filesystem posixerror $::vfs::posix(EACCES) ; return -code error $::vfs::posix(EACCES)} } createdirectory { CreateDirectory $path $root $relative $actualpath } deletefile { DeleteFile $path $root $relative $actualpath } fileattributes { set index [lindex $args 0] set value [lindex $args 1] array set attributes [FileAttributes $path $root $relative $actualpath] if {$index == {}} { return [lsort [array names attributes]] } set attribute [lindex [lsort [array names attributes]] $index] if {$value == {}} { return $attributes($attribute) } FileAttributesSet $path $root $relative $actualpath $attribute $value } matchindirectory { set pattern [lindex $args 0] set types [lindex $args 1] return [MatchInDirectory $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 $path $root $relative $actualpath $mode $permissions] switch -glob -- $mode { "" - "r*" - "w*" { seek $channelID 0 } "a*" { seek $channelID 0 end } default { ::vfs::filesystem posixerror $::vfs::posix(EINVAL) return -code error $::vfs::posix(EINVAL) } } set result $channelID lappend result [list ::vfs::template::quota::Close $channelID $path $root $relative $actualpath $mode] return $result } removedirectory { set recursive [lindex $args 0] if !$recursive { if {[MatchInDirectory $path $root $relative $actualpath * 0] != {}} { ::vfs::filesystem posixerror $::vfs::posix(EEXIST) return -code error $::vfs::posix(EEXIST) } } RemoveDirectory $path $root $relative $actualpath } stat { return [Stat $path $root $relative $actualpath] } utime { set atime [lindex $args 0] set mtime [lindex $args 1] Utime $path $root $relative $actualpath $atime $mtime } } } namespace eval ::vfs::template::quota { proc MountProcedure {args} { package require ::fileutil set to [file normalize [lindex $args end]] set args [lrange $args 0 end-1] set path [lindex $args 0] set args [lrange $args 1 end] if {![catch {vfs::filesystem info $to}]} { # unmount old mount Unmount $to } if [file isfile $path/quotavfs.txt] { set f [open $path/quotavfs.txt r] while {![eof $f]} { eval array set [gets $f] } close $f } set location $to set argsIndex [llength $args] incr argsIndex -1 for {set i $argsIndex} {$i >= 0} {incr i -1} { switch -- [lindex $args $i] { -number: - -total: { catch {set location $itemSet(location)} set item $itemSet(item) array unset itemSet $item set itemSet(type) [string range [lindex $args $i] 1 end-1] lappend ::vfs::template::quota::quota($location) $item catch {array set itemSet $::vfs::template::quota::${item}($location)} set ::vfs::template::quota::${item}($location) [array get itemSet] if ![info exists $itemSet(current)] {set enforceQuota 1} array unset itemSet set location $to } -item { set itemSet(item) [lindex $args [incr i]] } -location { set itemSet(location) [file join $path [lindex $args [incr i]]] } -pattern { set itemSet(rule) "CheckPattern [list [lindex $args [incr i]]]" } -quota { set itemSet(quota) [lindex $args [incr i]] } -rule { set itemSet(rule) [lindex $args [incr i]] } } } if [info exists enforceQuota] { foreach {location items} [array get ::vfs::template::quota::quota] { foreach item $items { array unset itemSet array set itemSet $::vfs::template::quota::${item}($location) array set itemSet "current 0" set ::vfs::template::quota::${item}($location) [array get itemSet] } ::fileutil::find $location CalculateQuota } } file mkdir $path lappend pathto $path lappend pathto $to return $pathto } proc UnmountProcedure {path to} { set f [open $path/quotavfs.txt w] puts $f "::vfs::template::quota::mtimes [list [array get ::vfs::template::quota::mtimes]]" array unset ::vfs::template::quota::mtimes puts $f "::vfs::template::quota::quota [list [array get ::vfs::template::quota::quota]]" foreach {location item} [array get ::vfs::template::quota::quota] { puts $f "::vfs::template::quota::${item} [list [array get ::vfs::template::quota::${item}]]" array unset ::vfs::template::quota::${item} } array unset ::vfs::template::quota::quota close $f return } proc Access {path root relative actualpath mode} { set modeString [::vfs::accessMode $mode] if {$modeString == "F"} {set modeString RWX} set modeString [split $modeString {}] set fileName [file join $path $relative] if [file readable $fileName] {lappend fileString R} if [file writable $fileName] {lappend fileString W} if [file executable $fileName] {lappend fileString X} foreach mS $modeString { set errorMessage "not [string map {R readable W writable X executable} $mS]" if {[lsearch $fileString $mS] == -1} {error $errorMessage} } } proc CreateDirectory {path root relative actualpath} { file mkdir [file join $path $relative] } proc DeleteFile {path root relative actualpath} { set fileName [file join $path $relative] file delete $fileName } proc FileAttributes {path root relative actualpath} { set fileName [file join $path $relative] file attributes $fileName } proc FileAttributesSet {path root relative actualpath attribute value} { set fileName [file join $path $relative] file attributes $fileName $attribute $value } proc MatchInDirectory {path root relative actualpath pattern types} { if [::vfs::matchDirectories $types] {lappend typeString d} if [::vfs::matchFiles $types] {lappend typeString f} set globList [glob -directory [file join $path $relative] -nocomplain -types $typeString $pattern] set pathLength [expr [string length $path] - 1] set newGlobList {} foreach gL $globList { if {[file tail $gL] == "quotavfs.txt"} {continue} set gL [string replace $gL 0 $pathLength $root] lappend newGlobList $gL } return $newGlobList } proc Open {path root relative actualpath mode permissions} { set fileName [file join $path $relative] set newFile 0 if ![file exists $fileName] { set newFile 1 } else { file stat $fileName fs array set fs [file attributes $fileName] } set fs(filename) [file tail [file join $path $relative]] set fs(dirname) [file dirname [file join $path $relative]] EnforceQuota [array get fs] foreach {item quotaDir} $::vfs::template::quota::overlimit { array unset itemSet array set itemSet $::vfs::template::quota::${item}($quotaDir) if ![string first $quotaDir/ $fileName] {continue} if {($itemSet(type) == "total") || ([eval $itemSet(rule) \$fs(\$item)])} { vfs::filesystem posixerror $::vfs::posix(ENOSPC) ; return -code error $::vfs::posix(ENOSPC) } } set channelID [open $fileName $mode] if $newFile {catch {file attributes $fileName -permissions $permissions}} return $channelID } proc Close {channelID path root relative actualpath mode} { # Do not close the channel in the close callback! # It will crash Tcl! Honest! # The core will close the channel after you've taken what info you need from it. # close $channelID set tempFile [::fileutil::tempfile] set f [open $tempFile w] seek $channelID 0 fconfigure $channelID -translation binary fconfigure $f -translation binary fcopy $channelID $f close $f file stat $tempFile fs array set fs [file attributes $tempFile] file delete $tempFile set fs(filename) [file tail [file join $path $relative]] set fs(dirname) [file dirname [file join $path $relative]] EnforceQuota [array get fs] return } proc RemoveDirectory {path root relative actualpath} { file delete -force [file join $path $relative] } proc Stat {path root relative actualpath} { 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 array set ::vfs::template::quota::mtimes "$mtime [file join $path $relative]" } proc CalculateQuota {name} { set currentDir [pwd] file stat $name fs array set fs [file attributes $name] array set fs "filename $name" array set fs "dirname $currentDir" array set ::vfs::template::quota::mtimes "$fs(mtime) $name" QuotaCheck [array get fs] return 0 } proc CheckPattern {pattern value} { foreach ptn $pattern { set negate [string equal [string index $ptn 0] !] if $negate {set ptn [string range $ptn 1 end]} set match [string match $ptn $value] if $negate {set match [expr !$match]} if $match {return $match} } return 0 } proc CheckTotal {quota current value} { if {[expr $current + $value] > $quota} {return 1} return 0 } proc EnforceQuota {args} { eval array set fs $args QuotaCheck [array get fs] foreach {item quotaDir} $::vfs::template::quota::overlimit { set underLimit 0 array unset itemSet array set itemSet $::vfs::template::quota::${item}($quotaDir) foreach mT [lsort [array names ::vfs::template::quota::mtimes]] { set mTFile $::vfs::template::quota::mtimes($mT) if {$mTFile == [file join $fs(dirname) $fs(filename)]} {continue} array unset mTStat file stat $mTFile mTStat array set mTStat [file attributes $mTFile] set mTStat(filename) [file tail $mTFile] set mTStat(dirname) [file dirname $mTFile] if ![info exists mTStat($item)] {continue} if ![string first $quotaDir/ $mTFile] {continue} if {($itemSet(type) == "total") || ([eval $itemSet(rule) \$mTStat(\$item)])} { file delete $mTFile array unset ::vfs::template::quota::mtimes $mT if {$itemSet(type) == "number"} {incr itemSet(current) -1} else {set itemSet(current) [expr $itemSet(current) - $fs($item)]} } if {$itemSet(current) <= $itemSet(quota)} {set underLimit 1 ; break} } if $underLimit { set oL [lsearch $::vfs::template::quota::overlimit "$item $quotaDir"] set ::vfs::template::quota::overlimit [lreplace $::vfs::template::quota::overlimit $oL $oL] } } } proc QuotaCheck {args} { eval array set fs $args set currentDir $fs(dirname) set quotaCheck 0 foreach quotaDir [lsort -decreasing [array names ::vfs::template::quota::quota]] { if ![string first $quotaDir/ $currentDir/] {set quotaCheck 1 ; break} } if !$quotaCheck {return 0} foreach item $::vfs::template::quota::quota($quotaDir) { if ![info exists fs($item)] {continue} array unset itemSet array set itemSet $::vfs::template::quota::${item}($quotaDir) if ![info exists $itemSet(current)] {set current 0} else {set current $itemSet(current)} if {($itemSet(type) == "total") || ([eval $itemSet(rule) \$fs(\$item)])} { if {$itemSet(type) == "number"} {incr current} else {set current [expr $current + $fs($item)]} } array set itemSet "current $current" if {$itemSet(current) > $itemSet(quota)} {lappend ::vfs::template::quota::overlimit "$item [list $quotaDir]"} set $::vfs::template::quota::${item}($quotaDir) [array get itemSet] } return 1 } } # end namespace eval vfs::template::quota