+2006-10-23 Steve Huntley <stephen.huntley@alum.mit.edu>
+
+ Initial upload of template virtual filesystems in new subfolder:
+ * library/template/collatevfs.tcl
+ * library/template/deltavfs.tcl
+ * library/template/fishvfs.tcl
+ * library/template/quotavfs.tcl
+ * library/template/templatevfs.tcl
+ * library/template/versionvfs.tcl
+
+ Plus helper utlities:
+ * library/template/tdelta.tcl - required by deltavfs.tcl
+ * library/template/globfind.tcl - required by quotavfs.tcl
+
+ * library/pkgIndex.tcl - added "package ifneeded" statements for
+ template virtual filesystems.
+
2006-09-29 Jeff Hobbs <jeffh@ActiveState.com>
* library/httpvfs.tcl (vfs::http::geturl): wrapper around
package ifneeded vfs::webdav 0.1 [list source [file join $dir webdavvfs.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
+if 0 {
+########################
+
+collatevfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.0
+
+A collate/broadcast/collect/catchup virtual filesystem. Requires the template vfs in templatevfs.tcl.
+
+Collate: reads from multiple specified directories and presents the results as one at the mount location.
+
+Broadcast: applies all writes in the mount location to multiple specified directories.
+
+Collect: copies any file read from or written to any of the above locations to specified directories.
+
+Catchup: If any specified directory is not available during any write action, the action is recorded in
+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>
+
+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
+option flag is optional, one could for example use only the -read flag to create a read-only directory. Directories
+do not have to exist and may go missing after mount, non-reachable locations will be ignored.
+
+Options:
+
+-read
+When an individual file is opened for reading, each of the directories specified is searched in
+order for the file; the first file found with the appropriate name is opened. When a subdirectory listing is
+generated, the combined files of the corresponding subdirectory of all specified directories are listed together.
+
+-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.
+
+-collect
+Auto-generates one or more file caches; a copy of any file opened for reading or writing in any of the above
+specified directories is made to each directory specified with the -collect flag. Collect locations are
+not included in file or directory listings, and are not searched for read access; so in order to make an
+active read cache, for example, one would have to include one directory location in both the -read and -collect sets.
+
+-catchup
+If this flag is included, the catchup function is activated, and a copy of the catchup queue is stored in a
+file in each of the specified directories. File writes, directory creations and file/directory deletes are
+stored in the catchup queue if any write location is offline; at the next write/creation/delete the queue is
+examined, and if any skipped action can be completed due to a location becoming available again, it
+will be. A catchup attempt will be made at mount time if this flag is included.
+
+The values of each option can be changed dynamically after mount by using the "file attributes" command on the
+mount virtual directory. Each option is editable as an attribute; i.e., "file attributes C:/collate -write C:/tmp"
+
+The collate vfs inherits the -cache and -volume options of the template vfs.
+
+
+Example use: specify parallel locations on a hard drive, on a CD-ROM mount and an ftp vfs as the read list.
+Files will be read first from the hard drive, if not found there the CD-ROM and ftp site will be searched in turn.
+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
+
+
+Example collect location use: specify a single hard drive location as a read and collect directory.
+Specify a ftp vfs as a secondary read directory. As ftp files are downloaded they are copied to the
+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
+
+
+########################
+}
+
+package provide vfs::template::collate 1.0
+
+package require vfs::template
+
+namespace eval ::vfs::template::collate {
+
+# 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
+}
+
+# edit following procedures:
+proc close_ {channel} {
+ upvar root root relative relative
+ foreach file [lrange [WriteFile $root $relative close] 1 end] {
+ set f [open $file w]
+ seek $channel 0
+ fcopy $channel $f
+ close $f
+ }
+ return
+}
+proc file_atime {file time} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ file atime $file $time
+}
+proc file_mtime {file time} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ file mtime $file $time
+}
+proc file_attributes {file {attribute {}} args} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ if {($relative == {}) && ([string map {-read 1 -write 1 -collect 1 -catchup 1} $attribute] == 1)} {
+ set attribute [string range $attribute 1 end]
+ if {$args == {}} {eval return \$::vfs::template::collate::${attribute}(\$root)}
+ set ::vfs::template::collate::${attribute}($root) [lindex $args 0]
+ set ::vfs::template::collate::catchup [file isdirectory [lindex $::vfs::template::collate::catchupstore 0]]
+ 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)]"}
+ return $returnValue
+}
+proc file_delete {file} {
+ upvar root root relative relative
+ foreach file [WriteFile $root $relative delete] {
+ file delete -force -- $file
+ }
+}
+proc file_executable {file} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ file executable $file
+}
+proc file_exists {file} {
+ upvar root root relative relative
+ expr ![catch {AcquireFile $root $relative}]
+}
+proc file_mkdir {file} {
+ upvar root root relative relative
+ foreach file [WriteFile $root $relative mkdir] {
+ file mkdir $file
+ }
+}
+proc file_readable {file} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ file readable $file
+}
+proc file_stat {file array} {
+ upvar root root relative relative
+ set file [AcquireFile $root $relative]
+ upvar $array fs ; file stat $file fs
+}
+proc file_writable {file} {
+ upvar root root relative relative
+ expr ![catch {WriteFile $root $relative open}]
+}
+proc glob_ {directory dir nocomplain tails types typeString dashes pattern} {
+ upvar root root relative relative
+ set allFiles {}
+ 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 [lsort -unique $allFiles]
+ return $allFiles
+}
+proc open_ {file mode} {
+ upvar root root relative relative
+ if [string match w* $mode] {
+ set file [lindex [WriteFile $root $relative open] 0]
+ file mkdir [file dirname $file]
+ return [open $file $mode]
+ }
+ if [string match r* $mode] {
+ set file [AcquireFile $root $relative]
+ if {$mode == "r"} {
+ foreach cpath $::vfs::template::collate::collect($root) {
+ set cfile [file join $cpath $relative]
+ if {$file == $cfile} {continue}
+ if ![file exists $cpath] {continue}
+ file mkdir [::file dirname $cfile]
+ file copy -force -- $file $cfile
+ }
+ return [open $file r]
+ }
+ set wfile [lindex [WriteFile $root $relative open] 0]
+ file mkdir [file dirname $wfile]
+ if {$wfile != $file} {file copy -force -- $file $wfile}
+ return [open $wfile $mode]
+ }
+ if [string match a* $mode] {
+ set wfile [lindex [WriteFile $root $relative open] 0]
+ file mkdir [file dirname $wfile]
+ if ![catch {set file [AcquireFile $root $relative]}] {
+ if {$wfile != $file} {file copy -force -- $file $wfile}
+ }
+ return [open $wfile $mode]
+ }
+}
+
+proc MountProcedure {args} {
+ upvar volume volume
+
+# take real and virtual directories from command line args.
+ set to [lindex $args end]
+ if [string equal $volume {}] {set to [::file normalize $to]}
+
+# add custom handling for new vfs args here.
+
+ set ::vfs::template::collate::catchup($to) 0
+ set ::vfs::template::collate::read($to) {}
+ set ::vfs::template::collate::write($to) {}
+ set ::vfs::template::collate::collect($to) {}
+ set ::vfs::template::collate::catchupstore($to) {}
+
+ set args [lrange $args 0 end-1]
+ set argsIndex [llength $args]
+ for {set i 0} {$i < $argsIndex} {incr i} {
+ set arg [lindex $args $i]
+
+ switch -- $arg {
+ -read {
+ set type read
+ }
+ -write {
+ set type write
+ }
+ -collect {
+ set type collect
+ }
+ -catchup {
+ set ::vfs::template::collate::catchup($to) 1
+ set type catchupstore
+ }
+ default {
+ eval lappend ::vfs::template::collate::${type}(\$to) \[::file normalize \$arg\]
+ }
+ }
+ }
+
+ WriteFile $to {} mkdir
+
+# return two-item list consisting of real and virtual locations.
+ lappend pathto {}
+ lappend pathto $to
+ return $pathto
+}
+
+proc UnmountProcedure {path to} {
+# add custom unmount handling of new vfs elements here.
+ unset -nocomplain ::vfs::template::collate::read($to)
+ unset -nocomplain ::vfs::template::collate::write($to)
+ unset -nocomplain ::vfs::template::collate::collect($to)
+ unset -nocomplain ::vfs::template::collate::catchup($to)
+ unset -nocomplain ::vfs::template::collate::catchupstore($to)
+ return
+}
+
+proc AcquireFile {root relative} {
+ foreach path $::vfs::template::collate::read($root) {
+ set file [::file join $path $relative]
+ if [::file exists $file] {
+ return $file
+ }
+ }
+ vfs::filesystem posixerror $::vfs::posix(ENOENT) ; return -code error $::vfs::posix(ENOENT)
+}
+
+proc WriteFile {root relative action} {
+ set allWriteLocations {}
+ foreach awl [concat $::vfs::template::collate::write($root) $::vfs::template::collate::collect($root)] {
+ if {[lsearch $allWriteLocations $awl] < 0} {lappend allWriteLocations $awl}
+ }
+ if ![llength $allWriteLocations] {
+ vfs::filesystem posixerror $::vfs::posix(EROFS) ; return -code error $::vfs::posix(EROFS)
+ }
+ if {$vfs::template::collate::catchup($root) && ([file tail $relative] != ".vfs_catchup") && ($action != "open")} {
+ set catchupActivate 1
+ set addCatchup {}
+ set newCatchup {}
+ } else {
+ set catchupActivate 0
+ }
+ set returnValue {}
+ foreach path $allWriteLocations {
+ if {$catchupActivate && ![file exists $path]} {
+ append addCatchup "[list $action $path $relative]\n"
+ continue
+ }
+ set rvfile [file join $path $relative]
+ if {[lsearch $returnValue $rvfile] == -1} {lappend returnValue $rvfile}
+ }
+ if {$returnValue == {}} {vfs::filesystem posixerror $::vfs::posix(EROFS) ; return -code error $::vfs::posix(EROFS)}
+ if $catchupActivate {
+ set catchup {}
+ set ::vfs::template::vfs_retrieve 1
+
+ foreach store $::vfs::template::collate::catchupstore($root) {
+ set store [file join $store ".vfs_catchup"]
+ if [file readable $store] {
+ set f [open $store r]
+ unset ::vfs::template::vfs_retrieve
+ seek $f 0
+ set catchup [read $f]
+ close $f
+ break
+ }
+ }
+ catch {set currentRead [AcquireFile $root {}]} result
+ foreach {action path rel} $catchup {
+ if {$relative == $rel} {continue}
+ if ![file exists $path] {append newCatchup "[list $action $path $rel]\n" ; continue}
+ if {[lsearch $allWriteLocations $path] < 0} {continue}
+ switch -- $action {
+ close {
+ if {![info exists currentRead] || ([set source [file join $currentRead $rel]] == [set target [file join $path $rel]])} {
+ append newCatchup "[list $action $path $rel]\n" ; continue
+ }
+ if ![file exists $source] {continue}
+ file copy -force -- $source $target
+ }
+ delete {
+ file delete -force -- [file join $path $rel]
+ }
+ mkdir {
+ file mkdir [file join $path $rel]
+ }
+ }
+ }
+ append newCatchup $addCatchup
+ foreach path $::vfs::template::collate::catchupstore($root) {
+ set vfscatchup [file join $path ".vfs_catchup"]
+ set ::vfs::template::vfs_retrieve 1
+ set err [catch {
+ if {$newCatchup != {}} {
+ set f [open $vfscatchup w]
+ puts $f $newCatchup
+ close $f
+ } else {
+ file delete $vfscatchup
+ }
+ } result]
+ unset ::vfs::template::vfs_retrieve
+ }
+ }
+ return $returnValue
+}
+
+}
+# end namespace ::vfs::template::collate
+
--- /dev/null
+if 0 {
+########################
+
+deltavfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.0
+
+A delta virtual filesystem. Requires the template vfs in templatevfs.tcl.
+
+Mount the delta vfs first, then mount the versioning vfs using the virtual location created by the
+delta vfs as its existing directory.
+
+As the versioning filesystem generates a new separate file for every file edit, this filesystem will
+invisibly generate and manage deltas of the separate versions to save space.
+
+
+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
+
+namespace eval ::vfs::template::version::delta {
+
+# 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
+}
+
+# edit following procedures:
+proc close_ {channel} {
+ upvar path path relative relative
+ set file [file join $path $relative]
+ set fileName $file
+ set f [open $fileName w]
+ fconfigure $f -translation binary
+ seek $f 0
+ seek $channel 0
+ fcopy $channel $f
+ close $f
+ Delta $fileName
+ return
+}
+proc file_atime {file time} {
+ set file [GetFileName $file]
+ file atime $file $time
+}
+proc file_mtime {file time} {
+ set file [GetFileName $file]
+ file mtime $file $time
+}
+proc file_attributes {file {attribute {}} args} {
+ set file [GetFileName $file]
+ eval file attributes \$file $attribute $args
+}
+proc file_delete {file} {
+ if [file isdirectory $file] {catch {file delete $file}}
+
+ set fileName [GetFileName $file]
+ set timeStamp [lindex [split [file tail $fileName] \;] 1]
+ if [string equal $timeStamp {}] {
+ catch {file delete $fileName} result
+ return
+ }
+ set targetFile [Reconstitute $fileName]
+ set referenceFiles [glob -directory [file dirname $fileName] -nocomplain *vfs&delta$timeStamp]
+ if {[lindex [file system $fileName] 0] != "tclvfs"} {append referenceFiles " [glob -directory [file dirname $fileName] -nocomplain -type hidden *vfs&delta$timeStamp]"}
+ foreach referenceFile $referenceFiles {
+ regsub {\;vfs&delta[0-9]*$} $referenceFile "" reconFile]
+ set f [open $referenceFile r]
+ fconfigure $f -translation binary
+ set signature [read $f]
+ close $f
+ tpatch $targetFile $signature $reconFile
+ file delete $referenceFile
+ }
+ close $targetFile
+
+ file delete -force -- $fileName
+}
+proc file_executable {file} {
+ set file [GetFileName $file]
+ file executable $file
+}
+proc file_exists {file} {
+ set file [GetFileName $file]
+ file exists $file
+}
+proc file_mkdir {file} {file mkdir $file}
+proc file_readable {file} {
+ set file [GetFileName $file]
+ file readable $file
+}
+proc file_stat {file array} {
+ upvar $array fs
+ set fileName [GetFileName $file]
+
+ set endtag [lindex [split $fileName \;] end]
+ if {[string first "vfs&delta" $endtag] || [string equal "vfs&delta" $endtag]} {file stat $fileName fs ; return}
+ set f [open $fileName r]
+ fconfigure $f -translation binary
+ set copyinstructions [read $f]
+ close $f
+ array set fileStats [lindex $copyinstructions 3]
+ unset copyinstructions
+ set size $fileStats(size)
+ file stat $fileName fs
+ set fs(size) $size
+ return
+}
+proc file_writable {file} {
+ set file [GetFileName $file]
+ file writable $file
+}
+proc glob_ {directory dir nocomplain tails types typeString dashes pattern} {
+ set globList [glob -directory $dir -nocomplain -tails -types $typeString -- $pattern]
+ set newGlobList {}
+ foreach gL $globList {
+ regsub {\;vfs&delta.*$} $gL "" gL
+ lappend newGlobList $gL
+ }
+ return $newGlobList
+}
+proc open_ {file mode} {
+ set fileName [GetFileName $file]
+
+ set newFile 0
+ if ![file exists $fileName] {set newFile 1}
+ set fileName $file
+ set channelID [Reconstitute $fileName]
+ if [string equal $channelID {}] {set channelID [open $fileName $mode] ; close $channelID ; set channelID [::vfs::memchan]}
+ if $newFile {catch {file attributes $fileName -permissions $permissions}}
+ return $channelID
+}
+
+
+proc MountProcedure {args} {
+ upvar volume volume
+
+# take real and virtual directories from command line args.
+ set to [lindex $args end]
+ if [string equal $volume {}] {set to [::file normalize $to]}
+ set path [::file normalize [lindex $args end-1]]
+
+# make sure mount location exists:
+ ::file mkdir $path
+
+# add custom handling for new vfs args here.
+ package require trsync
+ namespace import -force ::trsync::tdelta ::trsync::tpatch
+
+# return two-item list consisting of real and virtual locations.
+ lappend pathto $path
+ lappend pathto $to
+ return $pathto
+}
+
+
+proc UnmountProcedure {path to} {
+# add custom unmount handling of new vfs elements here.
+
+ return
+}
+
+proc Delta {filename} {
+ set fileRoot [lindex [split [file tail $filename] \;] 0]
+ set fileNames [glob -nocomplain -path [file join [file dirname $filename] $fileRoot] *]
+ if {[lindex [file system $filename] 0] != "tclvfs"} {append fileNames " [glob -nocomplain -path [file join [file dirname $filename] $fileRoot] -type hidden *]"}
+ set nonDeltas {}
+ foreach fn $fileNames {
+ set endtag [lindex [split $fn \;] end]
+ if ![string first "vfs&delta" $endtag] {continue}
+ lappend nonDeltas $fn
+ set atimes($fn) [file atime $fn]
+ }
+ if {[set deltaIndex [llength $nonDeltas]] < 2} {return}
+ set nonDeltas [lsort -dictionary $nonDeltas]
+ incr deltaIndex -1
+ set i 0
+ while {$i < $deltaIndex} {
+ set referenceFile [lindex $nonDeltas $i]
+ set targetFile [lindex $nonDeltas [incr i]]
+ set signature [tdelta $referenceFile $targetFile $::trsync::blockSize 1 1]
+ set targetTimeStamp [lindex [split $targetFile \;] 1]
+
+ file stat $referenceFile fileStats
+ set signatureSize [string length $signature]
+ if {$signatureSize > $fileStats(size)} {
+ set fileName $referenceFile\;vfs&delta
+ file rename $referenceFile $fileName
+ continue
+ }
+
+ array set fileStats [file attributes $referenceFile]
+
+ set fileName $referenceFile\;vfs&delta$targetTimeStamp
+ set f [open $fileName w]
+ fconfigure $f -translation binary
+ puts -nonewline $f $signature
+ close $f
+ file delete $referenceFile
+ array set fileAttributes [file attributes $fileName]
+ if [info exists fileAttributes(-readonly)] {catch {file attributes $fileName -readonly 0}}
+ if [info exists fileAttributes(-permissions)] {catch {file attributes $fileName -permissions rw-rw-rw-}}
+ catch {file attributes $fileName -owner $fileStats(uid)}
+ catch {file attributes $fileName -group $fileStats(gid)}
+
+ catch {file mtime $fileName $fileStats(mtime)}
+ catch {file atime $fileName $fileStats(atime)}
+
+ foreach attr [array names fileStats] {
+ if [string first "-" $attr] {continue}
+ if [string equal [array get fileStats $attr] [array get fileAttributes $attr]] {continue}
+ if [string equal "-permissions" $attr] {continue}
+ catch {file attributes $fileName $attr $fileStats($attr)}
+ }
+ catch {file attributes $fileName -permissions $fileStats(mode)}
+ catch {file attributes $fileName -readonly $fileStats(-readonly)}
+ }
+ foreach fn [array names atimes] {
+ if ![file exists $fn] {continue}
+ file atime $fn $atimes($fn)
+ }
+}
+
+proc GetFileName {file} {
+ set fileNames [glob -nocomplain -path $file *]
+ if {[lindex [file system $file] 0] != "tclvfs"} {append fileNames " [glob -nocomplain -path $file -type hidden *]"}
+ set fileName [lindex $fileNames 0]
+ if [set i [expr [lsearch -exact $fileNames $file] + 1]] {set fileName [lindex $fileNames [incr i -1]]}
+ return $fileName
+}
+
+proc Reconstitute {fileName} {
+ if ![catch {set channelID [open $fileName r]}] {return $channelID}
+ if ![catch {set channelID [open $fileName\;vfs&delta r]}] {return $channelID}
+ set targetFiles [glob -nocomplain -path $fileName *]
+ if {[lindex [file system $fileName] 0] != "tclvfs"} {append targetFiles " [glob -nocomplain -path $fileName -type hidden *]"}
+ set targetFile [lindex $targetFiles 0]
+
+ set targetFile [string trim $targetFile]
+ if [string equal $targetFile {}] {return}
+ set fileStack {}
+ while {[string first "\;vfs&delta" $targetFile] > -1} {
+ if ![regexp {\;vfs&delta([0-9]+)$} $targetFile trash targetTime] {break}
+ set fileStack "[list $targetFile] $fileStack"
+ set targetFiles [glob -directory [file dirname $fileName] *\;$targetTime*]
+ if {[lindex [file system $fileName] 0] != "tclvfs"} {append targetFiles " [glob -directory [file dirname $fileName] -nocomplain -type hidden *\;$targetTime*]"}
+ set targetFile [lindex $targetFiles 0]
+
+ set atimes($targetFile) [file atime $targetFile]
+ }
+ set targetFile [open $targetFile r]
+ foreach fs $fileStack {
+ set f [open $fs r]
+ fconfigure $f -translation binary
+ set copyInstructions [read $f]
+ close $f
+ set fileToConstruct [::vfs::memchan]
+ tpatch $targetFile $copyInstructions $fileToConstruct
+ catch {close $targetFile}
+ set targetFile $fileToConstruct
+ }
+ foreach fn [array names atimes] {
+ file atime $fn $atimes($fn)
+ }
+ fconfigure $targetFile -translation auto
+ seek $targetFile 0
+ return $targetFile
+}
+
+}
+# end namespace ::vfs::template::version::delta
+
--- /dev/null
+#! /usr/bin/env tclsh
+
+if 0 {
+########################
+
+fishvfs.tcl --
+
+ A "FIles transferred over SHell" virtual filesystem
+ This is not an official "FISH" protocol client as described at:
+ http://mini.net/tcl/12792
+ but it utilizes the same concept of turning any computer that offers
+ access via ssh, rsh or similar shell into a file server.
+
+ Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+ License: Tcl license
+ Version 1.0
+
+ Usage: Mount ?-volume? \
+ ?-cache <number>? \ # cache retention seconds
+ ?-exec? \ # location of executable
+ ?-transport <protocol>? \ # can be ssh, rsh or plink
+ ?-user <username>? \ # remote computer login name
+ ?-password <password>? \ # remote computer login password
+ ?-host <remote hostname>? \ # remote computer domain name
+ ?-port <port number>? \ # override default port
+ ?<option> <value>?
+ <remote directory> \ # an existing directory on the remote filesystem
+ <virtual mount directory or URL>
+
+Options:
+
+-cache
+Sets number of seconds file information will dwell in cache after being retrieved.
+Default is 2. This value is viewable and editable after mount by calling
+"file attributes <virtual directory> -cache ?value?"
+
+-volume
+Volume specified in virtual directory pathname will be mounted as a virtual volume.
+
+-exec
+Full pathname of ssh or equivalent program. Default is name of the -transport option,
+which is assumed to be the name of the executable program findable in the PATH.
+
+-transport
+Protocol used to transport commands to remote computer. Built-in allowable values are
+ssh, rsh or plink. Extensible to new protocols with addition of a single command line
+formatting proc.
+
+The ssh option assumes rsa login protocol is set up so no interactive password entry
+is necessary.
+
+-user
+Login name at remote computer if necessary.
+
+-password
+Password for remote login name if necessary.
+
+-host
+Hostname of remote computer. Only necessary if not specified in virtual mount URL.
+
+-port
+Override default port if necessary.
+
+Arbitrary option/value pairs can be included in the command line; they may be useful if
+a custom new transport protocol handler is added which requires info not included in the
+provided set.
+
+The vfs can be mounted as a local directory, or as a URL in conjunction with
+the "-volume" option.
+
+The URL can be of the form:
+
+transport://[user[:password]@]host[:port][/filename]
+
+Option switches can be used in conjunction with a URL to specify connection
+information; the option switch values will override the URL values.
+
+
+Examples:
+
+ Mount -transport ssh -user root -host tcl.tk / /mnt/vfs/tcl
+
+ Mount -volume /home/foo rsh://foo@localcomp
+
+ 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
+
+
+Client configuration:
+
+ If the -exec option is not used, the shell client must be in the PATH; it must be
+ configured for non-interactive (no password prompt) use.
+
+ The value of the -transport option is used to load an appropriate handler
+ procedure which is called to handle the specifics of the particular client.
+ Handlers for the supported transports (ssh, rsh, plink) already exist.
+ New clients can be added simply by providing a suitable handler procedure.
+
+ server configuration:
+
+ The remote computer is assumed to be running an SSH server, have a sh-type shell and
+ the standard GNU fileutils, but otherwise no configuration is needed.
+
+########################
+}
+
+package provide vfs::template::fish 1.0
+
+package require vfs::template
+
+namespace eval ::vfs::template::fish {
+
+# 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 close_ {channelID} {
+ upvar root root path path relative relative
+ set fileName [file join $path $relative]
+
+ fconfigure $channelID -translation binary
+ seek $channelID 0 end
+ set channelSize [tell $channelID]
+
+# use cat to pump channel contents to target file:
+ set command "cat>'$fileName'\;cat>/dev/null"
+ Transport $root $command stdin $channelID
+
+# check file size to ensure proper transmission:
+ set command "ls -l '$fileName' | ( read a b c d x e\; echo \$x )"
+ set fileSize [Transport $root $command]
+ if {$channelSize != $fileSize} {error "couldn't save \"$fileName\": Input/output error" "Input/output error" {POSIX EIO {Input/output error}}}
+ return
+}
+
+proc file_atime {file time} {
+ upvar root root
+ set atime [clock format $time -format %Y%m%d%H%M.%S -gmt 1]
+ set command "TZ=UTC\; export TZ\; touch -a -c -t $atime '$file'"
+ Transport $root $command
+ return $time
+}
+
+proc file_mtime {file time} {
+ upvar root root
+ set mtime [clock format $time -format %Y%m%d%H%M.%S -gmt 1]
+ set command "TZ=UTC\; export TZ\; touch -c -m -t $mtime '$file'"
+ Transport $root $command
+ return $time
+}
+
+proc file_attributes {file {attribute {}} args} {
+ upvar root root
+ set tail [file tail $file]
+ set value $args
+
+# retrive info option:
+ if {([string equal $attribute {}]) || ([string equal $value {}])} {
+ set command "find '$file' -maxdepth 1 -name '$tail' -printf '%u %g %m\\n'"
+
+# set info option:
+ } elseif ![string first $attribute "-group"] {
+ set command "chgrp $value '$file'"
+ } elseif ![string first $attribute "-owner"] {
+ set command "chown $value '$file'"
+ } elseif ![string first $attribute "-permissions"] {
+ set command "chmod $value '$file'"
+ }
+
+ set returnValue [Transport $root $command]
+
+# format retrieved info:
+ if [string equal $attribute {}] {
+ return "-group [lindex $returnValue 1] -owner [lindex $returnValue 0] -permissions [lindex $returnValue 2]"
+ }
+ if [string equal $value {}] {
+ if ![string first $attribute "-group"] {
+ return [lindex $returnValue 1]
+ } elseif ![string first $attribute "-owner"] {
+ return [lindex $returnValue 0]
+ } elseif ![string first $attribute "-permissions"] {
+ return [lindex $returnValue 2]
+ }
+ }
+ return
+}
+
+proc file_delete {file} {
+ upvar root root
+ set command "rm -rf '$file'"
+ Transport $root $command
+}
+proc file_executable {file} {
+ file_access $file executable
+}
+proc file_exists {file} {
+ file_access $file exists
+}
+proc file_mkdir {file} {
+ upvar root root
+ set command "mkdir -p '$file'"
+ Transport $root $command
+}
+proc file_readable {file} {
+ file_access $file readable
+}
+
+if 0 {
+###
+In the interest of efficiency, the stat call grabs a lot of info.
+Since many operations require a stat call and then an access call, this proc
+grabs the file's access info as well as the stat info and caches it. Stat info
+for every file in the target directory is grabbed in one call and cached for
+possible future use.
+###
+}
+proc file_stat {file arrayName} {
+ upvar $arrayName array
+ upvar path path root root relative relative
+ set secs [clock seconds]
+ set cache $::vfs::template::fish::cache($root)
+
+# combined command retrieves access and stat info:
+ set command "if \[ -r '$file' \]\; then echo 1\; else echo 0\; fi \; if \[ -w '$file' \]\; then echo 1\; else echo 0\; fi \; if \[ -x '$file' \]\; then echo 1\; else echo 0\; fi \; if \[ -e '$file' \]\; then echo 1\; else echo 0\; fi \; find '[::file dirname $file]' -maxdepth 1 -xtype d -printf '%A@ %C@ %G %i %m %T@ %n %s %U \{%f\}\\n' \; echo / \; find '[::file dirname $file]' -maxdepth 1 -xtype f -printf '%A@ %C@ %G %i %m %T@ %n %s %U \{%f\}\\n'"
+
+# see if info is in cache:
+ set returnValue [CacheGet ::vfs::template::fish::stat [::file join $root $relative] $cache $secs]
+
+#if not, retrieve it:
+ if [string equal $returnValue {}] {
+ set returnValue [Transport $root $command]
+
+ set dir 1
+ set returnValue [split $returnValue \n]
+
+# split off access info and cache it:
+ set access [lrange $returnValue 0 3]
+ set returnValue [lrange $returnValue 4 end]
+ CacheSet ::vfs::template::fish::readable [file join $root $relative] [lindex $access 0] $secs
+ CacheSet ::vfs::template::fish::writable [file join $root $relative] [lindex $access 1] $secs
+ CacheSet ::vfs::template::fish::executable [file join $root $relative] [lindex $access 2] $secs
+ CacheSet ::vfs::template::fish::exists [file join $root $relative] [lindex $access 3] $secs
+
+# current dir info is first entry, discard it if file is not root:
+ if ![string equal $file "/"] {set returnValue [lrange $returnValue 1 end]}
+
+# format and cache info for each file in dir containing target file:
+ set pathLength [llength [file split $path]]
+ foreach rV $returnValue {
+ if [string equal $rV "/"] {set dir 0 ; continue}
+ set fileTail [lindex $rV end]
+ set fN [::file join $root [join [lrange [file split [file join [file dirname $file] $fileTail]] $pathLength end] /]]
+
+ set value "mtime [lindex $rV 5] gid [lindex $rV 2] nlink [lindex $rV 6] atime [lindex $rV 0] mode [lindex $rV 4] type [if $dir {set type directory} else {set type file}] ctime [lindex $rV 1] uid [lindex $rV 8] ino [lindex $rV 3] size [lindex $rV 7] dev -1"
+ CacheSet ::vfs::template::fish::stat $fN $value $secs
+
+ }
+# grab info for target file from cache:
+ set returnValue $::vfs::template::fish::stat([file join $root $relative],value)
+ }
+# feed info into upvar'd array:
+ array set array $returnValue
+ return
+}
+
+proc file_writable {file} {
+ file_access $file writable
+}
+
+if 0 {
+###
+glob call aims to increase efficiency by grabbing stat info of listed files, under
+assumption that a file listing is likely to be followed by an operation on one
+of the listed files:
+###
+}
+proc glob_ {d directory nocomplain tails types typeString dashes pattern} {
+
+ upvar 1 path path root root relative relative
+
+# list files along with their stat info:
+ set command "find '$directory' -maxdepth 1 -mindepth 1 -xtype d -printf '%A@ %C@ %G %i %m %T@ %n %s %U \{%f\}\\n' \; echo / \; find '$directory' -maxdepth 1 -mindepth 1 -xtype f -printf '%A@ %C@ %G %i %m %T@ %n %s %U \{%f\}\\n'"
+
+ set returnValue [Transport $root $command]
+ set secs [clock seconds]
+ set virtualName [file join $root $relative]
+
+ set dirs {}
+ set files {}
+ set dir 1
+
+# loop through file list and cache stat info:
+ foreach rV [split $returnValue \n] {
+ if [string equal $rV "/"] {set dir 0 ; continue}
+
+ set fileTail [lindex $rV end]
+ set fN [file join $virtualName $fileTail]
+
+ set value "mtime [lindex $rV 5] gid [lindex $rV 2] nlink [lindex $rV 6] atime [lindex $rV 0] mode [lindex $rV 4] type [if $dir {set type directory} else {set type file}] ctime [lindex $rV 1] uid [lindex $rV 8] ino [lindex $rV 3] size [lindex $rV 7] dev -1"
+ CacheSet ::vfs::template::fish::stat $fN $value $secs
+
+ if $dir {lappend dirs $fileTail} else {lappend files $fileTail}
+ }
+
+# decide to return dirs, files or both:
+ set dir [lsearch $typeString "d"]
+ set file [lsearch $typeString "f"]
+ incr dir ; incr file
+
+ if $dir {set values $dirs}
+ if $file {set values $files}
+ if {$dir && $file} {set values [concat $dirs $files]}
+
+# give filenames virtual paths:
+ set fileNames {}
+ foreach fileName $values {
+ if [string equal $fileName "."] {continue}
+ if [string equal $fileName ".."] {continue}
+ if ![string match $pattern $fileName] {continue}
+ lappend fileNames $fileName
+ }
+ return $fileNames
+}
+
+proc open_ {file mode} {
+ upvar root root
+
+# check existence and file size before retrieval:
+ set command "ls -l '$file' | ( read a b c d x e\; echo \$x )"
+ if {([catch {set fileSize [Transport $root $command]}]) && ($mode == "r")} {error "couldn't open \"$file\": no such file or directory" "no such file or directory" {POSIX ENOENT {no such file or directory}}}
+
+ set channelID [::vfs::memchan]
+
+# file must exist after open procedure, ensure it:
+ set command "touch -a '$file'"
+ Transport $root $command
+
+# if write mode, don't need to retrieve contents:
+ if [string match w* $mode] {return $channelID}
+
+# cat file contents to stdout and transfer to channelID:
+ fconfigure $channelID -translation binary
+ set command "cat '$file'"
+ Transport $root $command stdout $channelID
+
+# check if entire file contents transported:
+ seek $channelID 0 end
+ set channelSize [tell $channelID]
+ if {[info exists fileSize] && ($channelSize != $fileSize)} {error "Input/output error" "Input/output error" {POSIX EIO {Input/output error}}}
+ return $channelID
+}
+
+# all file access procs are redirected here for ease of programming:
+proc file_access {file type} {
+ upvar 2 root root relative relative
+
+ set command "if \[ -r '$file' \]\; then echo 1\; else echo 0\; fi \; if \[ -w '$file' \]\; then echo 1\; else echo 0\; fi \; if \[ -x '$file' \]\; then echo 1\; else echo 0\; fi \; if \[ -e '$file' \]\; then echo 1\; else echo 0\; fi"
+ set returnValue [Transport $root $command]
+ set access [split $returnValue \n]
+ set secs [clock seconds]
+
+ CacheSet ::vfs::template::fish::readable [file join $root $relative] [lindex $access 0] $secs
+ CacheSet ::vfs::template::fish::writable [file join $root $relative] [lindex $access 1] $secs
+ CacheSet ::vfs::template::fish::executable [file join $root $relative] [lindex $access 2] $secs
+ CacheSet ::vfs::template::fish::exists [file join $root $relative] [lindex $access 3] $secs
+
+ eval return \$::vfs::template::fish::${type}(\[file join \$root \$relative\],value)
+}
+
+proc MountProcedure {args} {
+ upvar volume volume
+
+ set to [lindex $args end]
+ set path [lindex $args end-1]
+ if [string equal $volume {}] {set to [file normalize $to]}
+
+# if virtual mount contains mount info, retrieve it:
+ array set params [FileTransport $to]
+
+# retrieve all option/value pairs from args list:
+ if {[llength $args] > 2} {
+ set args [lrange $args 0 end-2]
+ set argsIndex [llength $args]
+ for {set i 0} {$i < $argsIndex} {incr i} {
+ set arg [lindex $args $i]
+ if {[string index $arg 0] == "-"} {
+ set arg [string range $arg 1 end]
+ set params($arg) [lindex $args [incr i]]
+ }
+ }
+ }
+
+# local option if no other transport given, useful for testing:
+ if [string equal $params(transport) {}] {set params(transport) local}
+
+# default executable name is transport name:
+ if ![info exists params(exec)] {set params(exec) $params(transport)}
+
+# store parameters:
+ set ::vfs::template::fish::params($to) [array get params]
+ set ::vfs::template::fish::transport($to) $params(transport)
+
+# rewrite template vfshandler so appropriate transport proc is imported with each file operation:
+ set body "set trans \$::vfs::template::fish::transport(\$root) \; namespace import -force ::vfs::template::fish::\$\{trans\}::Transport \n"
+ append body [info body handler]
+ proc handler [info args handler] $body
+
+ lappend pathto $path
+ lappend pathto $to
+ return $pathto
+}
+
+proc UnmountProcedure {path to} {
+ unset ::vfs::template::fish::params($to)
+ unset ::vfs::template::fish::transport($to)
+ return
+}
+
+# execute commands, handle stdin/stdout if necessary:
+proc ExecCommand {root command args} {
+ array set params [lindex $args 0]
+ if [info exists params(stdin)] {
+ set execID [eval ::open \"|$command\" w]
+ fconfigure $execID -translation binary
+ seek $params(stdin) 0
+ puts -nonewline $execID [read $params(stdin)]
+ ::close $execID
+ return
+ }
+
+ if [info exists params(stdout)] {
+ set execID [eval ::open \"|$command\" r]
+ fconfigure $execID -translation binary
+ seek $params(stdout) 0
+ puts -nonewline $params(stdout) [read $execID]
+ ::close $execID
+ return
+ }
+ eval exec $command
+}
+# analyze virtual URL for mount information:
+proc FileTransport {filename} {
+ if {[string first : $filename] < 0} {return [list transport {} user {} password {} host {} port {} filename [file normalize $filename]]}
+ if {[string first [string range $filename 0 [string first : $filename]] [file volume]] > -1} {return [list transport {} user {} password {} host {} port {} filename [file normalize $filename]]}
+
+ set filename $filename/f
+ set transport {} ; set user {} ; set password {} ; set host {} ; set port {}
+
+ regexp {(^[^:]+)://} $filename trash transport
+ regsub {(^[^:]+://)} $filename "" userpasshost
+ set userpass [lindex [split $userpasshost @] 0]
+ set user $userpass
+ regexp {(^[^:]+):(.+)$} $userpass trash user password
+
+ if {[string first @ $userpasshost] == -1} {set user {} ; set password {}}
+
+ regsub {([^/]+)(:[^/]+)(@[^/]+)} $filename \\1\\3 filename
+
+ if [regexp {(^[^:]+)://([^/:]+)(:[^/:]*)*(.+$)} $filename trash transport host port filename] {
+ regexp {([0-9]+)} $port trash port
+ if {[string first [lindex [file split $filename] 1] [file volume]] > -1} {set filename [string range $filename 1 end]}
+ } else {
+ set host [lindex [split $filename /] 0]
+ set filename [string range $filename [string length $host] end]
+ set port [lindex [split $host :] 1]
+ set host [lindex [split $host :] 0]
+ }
+ regexp {^.+@(.+)} $host trash host
+ set filename [string range $filename 0 end-2]
+ return [list transport $transport user $user password $password host $host port $port filename $filename ]
+}
+
+
+}
+# end namespace ::vfs::template
+
+
+# Each transport procedure has its own namespace and Transport proc.
+# Copy and customize for new transport methods:
+
+namespace eval ::vfs::template::fish::local {
+ proc Transport {root command {std none} {chan none}} {
+ array set params "$std $chan"
+ return [::vfs::template::fish::ExecCommand $root $command [array get params]]
+ }
+ namespace export *
+}
+
+namespace eval ::vfs::template::fish::plink {
+ proc Transport {root command {std none} {chan none}} {
+ array set params $::vfs::template::fish::params($root)
+ array set params "$std $chan"
+
+ set port {}
+ if ![string equal $params(port) {}] {set port "-P $params(port)"}
+ set commandLine "[list $params(exec)] -ssh $port -l $params(user) -batch -pw $params(password) $params(host) [list $command]"
+
+ return [::vfs::template::fish::ExecCommand $root $commandLine [array get params]]
+ }
+ namespace export *
+}
+
+namespace eval ::vfs::template::fish::rsh {
+ proc Transport {root command {std none} {chan none}} {
+
+ array set params $::vfs::template::fish::params($root)
+ array set params "$std $chan"
+
+ set user {}
+ if ![string equal $params(user) {}] {set user "-l $params(user)"}
+ set commandLine "[list $params(exec)] $user $params(host) [list ${command}]"
+ return [::vfs::template::fish::ExecCommand $root $commandLine [array get params]]
+ }
+ namespace export *
+}
+
+namespace eval ::vfs::template::fish::ssh {
+ proc Transport {root command {std none} {chan none}} {
+
+ array set params $::vfs::template::fish::params($root)
+ array set params "$std $chan"
+
+ set port {}
+ if ![string equal $params(port) {}] {set port "-D $params(port)"}
+ set user {}
+ if ![string equal $params(user) {}] {set user "-l $params(user)"}
+ set commandLine "[list $params(exec)] $port $user $params(host) [list ${command}]"
+ return [::vfs::template::fish::ExecCommand $root $commandLine [array get params]]
+ }
+ namespace export *
+}
+
--- /dev/null
+package provide globfind 1.0
+
+namespace eval ::globfind {
+
+proc globfind {{basedir .} {filtercmd {}}} {
+ set depth 16
+ set filt [string length $filtercmd]
+ 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
+ }
+
+ 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
+ }
+ default {}
+ }
+ }
+ if $redo continue
+ if {$hidden == {}} {
+ set hidden "-types hidden"
+ } else {
+ set hidden {}
+ if {[llength $checkDirs] == 0} {set terminate 1}
+ }
+ set returnFiles [concat $returnFiles $allFiles]
+ }
+ set filterFiles {}
+ foreach filename [lsort -unique [linsert $returnFiles end $basedir]] {
+ if {!$filt || [uplevel $filtercmd [list $filename]]} {
+ lappend filterFiles $filename
+ }
+ }
+ return $filterFiles
+}
+
+
+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
+ }
+
+ array set signs {
+ - <
+ + >
+ }
+
+ array set multiplier {
+ time 86400
+ min 3600
+ }
+ 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}
+ }
+ -regex {
+ set value [lindex $switches [incr i]]
+ if ![regexp $value $filename] {return 0}
+ }
+ -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]}
+
+ if ![expr $fs(size) $sign $value] {return 0}
+ }
+ -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}
+ }
+ }
+ }
+ return 1
+}
+
+proc find {args} {
+ globfind [lindex $args 0] [list [subst "scfind $args"]]
+}
+
+namespace export -clear globfind
+
+}
+# end namespace globfind
+
+
+
--- /dev/null
+if 0 {
+########################
+
+quotavfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.0
+
+A quota-enforcing virtual filesystem. Requires the template vfs in templatevfs.tcl.
+
+Quotas can be set on any quantity returned by "file stat" or "file attributes",
+plus the attribute "filename", which is the fully normalized pathname of the file.
+
+Two types of quota can be set: an incremented count of files matching a certain criterion, and
+a running total of a certain quantity. Each quota is defined by a set of switches composing
+a "quota group," any number of quota groups can be defined. A file must fit within all quotas defined
+to avoid triggering quota enforcement.
+
+The quotas are enforced as a FIFO stack of files; that is, if a new file is copied to the vfs whose
+attributes exceed a quota, the file is not rejected, rather, the already present files with
+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.
+
+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>
+
+Quota group definition:
+
+-<quantity> <rule> -[quota|ruletotal] <quota number>
+or
+-<quantity> -total <quota number>
+
+Options:
+
+-<quantity>
+Where <quantity> is any item returned by the "file stat" or "file attributes" commands, with the dash
+prepended as needed, for example: -archive, -permissions, -size, -mtime etc. The attribute "filename"
+is assumed to exist as well, defined as the file's full pathname. The quantity need not exist, so the
+same command line could be used on Unix or Windows, for example. Nonexistent quantities have no effect
+and are ignored.
+
+<rule>
+The rule is the criterion a file must meet to have the quota applied to it. It may take the form of a
+list of glob patterns as used by the "string match" command: if the quantity value matches all the
+patterns, the quota is applied. The rule may be Tcl code, to which the quantity value will be
+appended and then evaluated. The code should return 1 if the file is judged to meet the
+quota criterion, or 0 if not. If glob patterns are used, each pattern in the list may, in
+addition to symbols used by "string match", have a "!" prepended to it, which will negate the
+sense of the match.
+
+-quota
+If the quota group contains this switch, then the vfs will keep a running count of all files that satisfy
+the quota group's rule. It will not allow more than the number of files specified in <quota number> to
+exist in the virtual file space.
+
+-total
+If the quota group contains this switch, then the vfs will track the sum of the values of the specified
+quantity of all files. It will not allow the sum specified in <quota number> to
+be exceeded in the virtual file space.
+
+-ruletotal
+Like -total, but a rule is defined, and only files satisfying the rule have their values added to the quota sum.
+
+The quota vfs inherits the -cache and -volume options of the template vfs.
+
+
+Examples -- to set a 10 MB size limit on your ftp upload directory:
+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
+
+To ban GIF files from your web site images subdirectory:
+Mount -filename /docroot/images/*.gif -quota 0 {C:/Program Files/Apache/htdocs} /docroot
+
+To disallow creation of subdirectories:
+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
+
+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
+
+package require globfind
+
+namespace eval ::vfs::template::quota {
+
+# 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
+}
+
+# edit following procedures:
+proc close_ {channel} {
+ upvar path path root root relative relative
+ fconfigure $channel -translation binary
+ seek $channel 0 end
+ set quotaSize [tell $channel]
+ seek $channel 0
+ set filechannel $::vfs::template::quota::channels($channel)
+
+# Check if edited size violates any size quotas before allowing commit:
+ if [catch {QuotaAdd [file join $path $relative]}] {close $filechannel ; error "Disk quota exceeded"}
+ seek $filechannel 0
+ fcopy $channel $filechannel
+ close $filechannel
+ return
+}
+proc file_atime {file time} {
+ upvar root root
+ file atime $file $time
+ append ::vfs::template::quota::atimes($root) " $time [list $file]"
+ if {$::vfs::template::quota::files($file) < $time} {set ::vfs::template::quota::files($file) $time ; return}
+ set ::vfs::template::quota::files($file) $time
+ set aList {}
+ foreach {atime afile} $::vfs::template::quota::atimes($root) {
+ lappend aList "$atime [list $afile]"
+ }
+ set atimes {}
+ foreach aset [lsort -dictionary $aList] {
+ set atime [lindex $aset 0]
+ set afile [lindex $aset 1]
+ append atimes " $atime [list $afile]"
+ }
+ set ::vfs::template::quota::atimes($root) $atimes
+}
+proc file_mtime {file time} {file mtime $file $time}
+proc file_attributes {file {attribute {}} args} {eval file attributes \$file $attribute $args}
+proc file_delete {file} {
+ upvar root root
+ array set quotaArray $::vfs::template::quota::quota($root)
+ QuotaDelete $file
+ return
+}
+proc file_executable {file} {file executable $file}
+proc file_exists {file} {file exists $file}
+proc file_mkdir {file} {
+ upvar root root
+ file mkdir $file
+ globfind $file QuotaAdd
+ return
+}
+proc file_readable {file} {file readable $file}
+proc file_stat {file array} {upvar $array fs ; ::file stat $file fs}
+proc file_writable {file} {file writable $file}
+proc glob_ {directory dir nocomplain tails types typeString dashes pattern} {glob -directory $dir -nocomplain -tails -types $typeString -- $pattern}
+proc open_ {file mode} {
+ upvar root root
+ upvar newFile newFile
+ if {$mode == "r"} {
+ set atime [clock seconds]
+ append ::vfs::template::quota::atimes($root) " $atime [list $file]"
+ set ::vfs::template::quota::files($file) $atime
+ return [open $file r]
+ }
+ set channel [open $file $mode]
+
+# Check if new file violates any quotas by adding it to quota tallies:
+ if $newFile {
+ set err [catch {QuotaAdd $file} result]
+ if $err {
+ close $channel
+ file delete -force -- $file
+ vfs::filesystem posixerror $::vfs::posix(EDQUOT)
+ error "Disk quota exceeded"
+ }
+ }
+# remove file from quota tallies until channel is closed:
+ array set quotaArray $::vfs::template::quota::quota($root)
+ QuotaDelete $file 0
+
+# Use memchan to store edits so edit can be rejected if it violates size quotas:
+ set memchannel [vfs::memchan]
+ seek $channel 0
+ fcopy $channel $memchannel
+ set [namespace current]::channels($memchannel) $channel
+ return $memchannel
+}
+
+proc MountProcedure {args} {
+ upvar volume volume
+
+# take real and virtual directories from command line args.
+ set to [lindex $args end]
+ if [string equal $volume {}] {set to [::file normalize $to]}
+ set path [::file normalize [lindex $args end-1]]
+
+# make sure mount location exists:
+ ::file mkdir $path
+
+# add custom handling for new vfs args here.
+
+ namespace import -force ::globfind::globfind
+ set quotaArgs [lrange $args 0 end-2]
+
+ ParseArgs ::vfs::template::quota::quota($to) $quotaArgs
+
+# Initialize quotas:
+ set root $to
+ set aList {}
+ foreach afile [globfind $path] {
+ file stat $afile fs
+ lappend aList "$fs(atime) [list $afile]"
+ }
+ set atimes {}
+ foreach aset [lsort -dictionary $aList] {
+ set atime [lindex $aset 0]
+ set afile [lindex $aset 1]
+ append atimes " $atime [list $afile]"
+ }
+ set ::vfs::template::quota::atimes($root) $atimes
+
+ globfind $path QuotaAdd
+
+ set ::vfs::template::quota::atimes($root) $atimes
+
+# return two-item list consisting of real and virtual locations.
+ lappend pathto $path
+ lappend pathto $to
+ return $pathto
+}
+
+
+proc UnmountProcedure {path to} {
+# add custom unmount handling of new vfs elements here.
+
+ unset -nocomplain ::vfs::template::quota::quota($to)
+ unset -nocomplain ::vfs::template::quota::atimes($to)
+ return
+}
+
+# Default rule for quotas with pattern specified:
+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 0}
+ }
+ return 1
+}
+
+# Used as argument to proc globfind to recurse down dir hierarchies and process each file and dir found:
+proc QuotaAdd {fileName} {
+ upvar path path root root quotaSize quotaSize
+ if ![string first ".vfs_" [file tail $fileName]] {return 0}
+ if {[info exists path] && ($fileName == $path)} {return 0}
+ array set quotaArray $::vfs::template::quota::quota($root)
+ set overLimit {}
+ set items [lsort -unique [string map {",type " " " ",rule " " " ",quota " " " ",current " " "} " [array names quotaArray] "]]
+
+ set delete 1
+ file stat $fileName fs
+ 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}
+
+# 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]"
+ set ::vfs::template::quota::files($fileName) $fs(atime)
+
+# Check each defined quota to see if given file violates it:
+ foreach item $items {
+ 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)]] {
+ 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)
+ }
+ set $quotaArray($groupCount,$item,current) [expr $quotaArray($groupCount,$item,current) + $fs($item)]
+ } else {
+ if {$quotaArray($groupCount,$item,quota == 0} {
+ if $delete {catch {file delete -force -- $fileName} result}
+ vfs::filesystem posixerror $::vfs::posix(EDQUOT)
+ }
+ incr quotaArray($groupCount,$item,current)
+ }
+ # If file violates quota, store quota to see if room can be made by deleting older files:
+ 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 {
+ 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 atime doesn't match latest value, delete record and move on:
+ if {($::vfs::template::quota::files($afile) != $atime) || ![file exists $afile]} {
+ set deleteLoc [lsearch -exact $::vfs::template::quota::atimes($root) $afile]
+ set ::vfs::template::quota::atimes($root) [lreplace $::vfs::template::quota::atimes($root) [expr $deleteLoc - 1] $deleteLoc]
+ if {[lsearch -exact $::vfs::template::quota::atimes($root) $afile] < 0} {unset ::vfs::template::quota::files($afile)}
+ continue
+ }
+
+ # if file from queue is in fact newer than given file, skip it:
+ if {$atime > $fs(atime)} {continue}
+
+ # if stored filename is same as given filename, given filename violates quota and must be rejected:
+ if {$afile == $fileName} {
+ catch {QuotaDelete $fileName $delete}
+ set ::vfs::template::quota::quota($root) [array get quotaArray]
+ 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]] {
+ set ::vfs::template::quota::quota($root) [array get quotaArray]
+ QuotaDelete $afile
+ }
+
+ # If deletions make room for new file, then OK:
+ if {$quotaArray($item,current) <= $quotaArray($item,quota)} {break}
+ }
+ }
+ set ::vfs::template::quota::quota($root) [array get quotaArray]
+ return 0
+}
+
+proc QuotaDelete {fileName {delete 1}} {
+ upvar quotaArray quotaArray quotaSize quotaSize
+ set items [lsort -unique [string map {",type " " " ",rule " " " ",quota " " " ",current " " "} " [array names quotaArray] "]]
+
+# If given fileName is a dir, must remove all contents from quota tallies before removing dir itself:
+ set files [lsort -decreasing [globfind $fileName]]
+ set type file
+
+# 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}
+ set stat($file) [array get fs]
+ }
+ array set fs $stat($file)
+
+ # If file type is wrong for this pass, continue:
+ if {($type == "file") && ($fs(type) == "directory")} {continue}
+ if {($type == "directory") && ($fs(type) != "directory")} {continue}
+
+ # Check each quota to see if current file contributes to it:
+ foreach item $items {
+ 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]] {
+ if {$quotaArray($groupCount,$item,type) == "total"} {
+ set $quotaArray($groupCount,$item,current) [expr $quotaArray($groupCount,$item,current) - $fs($item)]
+ } else {
+ incr quotaArray($groupCount,$item,current) -1
+ }
+ }
+ }
+
+ # After removing file from quota tallies, delete it:
+ if $delete {file delete -force -- $file}
+ }
+ return
+}
+
+# Decided on new command line syntax, rather than rewrite whole vfs,
+# this proc casts new syntax into old format, then processes as before:
+proc ParseArgs {argsStore args} {
+ upvar path path
+ set args [lindex $args 0]
+
+ array set attrs [file attributes $path]
+ set quotas {}
+ set totals {}
+ set rtotals {}
+ set newArgs {}
+
+# find location of each quota group:
+ set qPosition [lsearch -all $args "-quota"]
+ set tPosition [lsearch -all $args "-total"]
+ set rPosition [lsearch -all $args "-ruletotal"]
+
+# break group defs into separate categories:
+ foreach qp $qPosition {
+ incr qp
+ append quotas " [lrange $args [expr $qp - 3] $qp]"
+ }
+
+ foreach tp $tPosition {
+ incr tp
+ append totals " [lrange $args [expr $tp - 2] $tp]"
+ }
+
+ foreach rp $rPosition {
+ incr rp
+ append rtotals " [lrange $args [expr $rp - 3] $rp]"
+ }
+
+# 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 ![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"
+ }
+
+ 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 ![info exists attrs($type)] {set type [string range $type 1 end]}
+ append newArgs " -total: -item $type $patrul [list $pr] -quota $number"
+ }
+
+# process old syntax:
+ unset args
+ lappend args [string trim $newArgs]
+
+ set groupCount 0
+ set args [lindex $args 0]
+ set argsIndex [llength $args]
+ for {set i $argsIndex} {$i >= 0} {incr i -1} {
+ switch -- [lindex $args $i] {
+ -number: -
+ -total: {
+ set item $itemSet(item)
+ if ![info exists itemSet(rule)] {set itemSet(rule) "CheckPattern *"}
+ set argsArray($groupCount,$item,type) [string range [lindex $args $i] 1 end-1]
+ set argsArray($groupCount,$item,rule) $itemSet(rule)
+ set argsArray($groupCount,$item,quota) $itemSet(quota)
+ set argsArray($groupCount,$item,current) 0
+ array unset itemSet
+ incr groupCount
+ }
+ -item {
+ set itemSet(item) [lindex $args [expr $i + 1]]
+ }
+ -pattern {
+ set itemSet(rule) "CheckPattern [list [lindex $args [expr $i + 1]]]"
+ }
+ -quota {
+ set itemSet(quota) [lindex $args [expr $i + 1]]
+ }
+ -rule {
+ set itemSet(rule) [lindex $args [expr $i + 1]]
+ }
+ }
+ }
+ set $argsStore [array get argsArray]
+}
+
+}
+# end namespace ::vfs::template::quota
+
+
--- /dev/null
+# tdelta.tcl --
+#
+# Produce an rdiff-style delta signature of one file with respect to another,
+# and re-create one file by applying the delta to the other.
+#
+# Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+#
+# Usage:
+#
+# tdelta <reference file | channel> <target file | channel> [sizecheck [fingerprint]]
+# Returns a delta of the target file with respect to the reference file.
+# i.e., using patch to apply the delta to the target file will re-create the reference file.
+#
+# sizecheck and fingerprint are booleans which enable time-saving checks:
+#
+# if sizecheck is True then if the file size is
+# less than five times the block size, then no delta calculation is done and the
+# signature contains the full reference file contents.
+#
+# if fingerprint is True then 10 small strings ("fingerprints") are taken from the target
+# file and searched for in the reference file. If at least three aren't found, then
+# no delta calculation is done and the signature contains the full reference file contents.
+#
+# tpatch <target file | channel> <delta signature> <output file (duplicate of reference file) | channel>
+# Reconstitute original reference file by applying delta to target file.
+#
+#
+# global variables:
+#
+# blockSize
+# Size of file segments to compare.
+# Smaller blockSize tends to create smaller delta.
+# Larger blockSize tends to take more time to compute delta.
+# md5Size
+# Substring of md5 checksum to store in delta signature.
+# If security is less of a concern, set md5Size to a number
+# between 1-32 to create a more compact signature.
+
+package provide trsync 1.0
+
+namespace eval ::trsync {
+
+if ![info exists blockSize] {variable blockSize 100}
+if ![info exists Mod] {variable Mod [expr pow(2,16)]}
+if ![info exists md5Size] {variable md5Size 32}
+
+variable temp
+if ![info exists temp] {
+ catch {set temp $::env(TMP)}
+ catch {set temp $::env(TEMP)}
+ catch {set temp $::env(TRSYNC_TEMP)}
+ if [catch {file mkdir $temp}] {set temp [pwd]}
+}
+if ![file writable $temp] {error "temp location not writable"}
+
+proc Backup {args} {
+ return
+}
+
+proc ConstructFile {copyinstructions {eolNative 0} {backup {}}} {
+ if [catch {package present md5 2}] {package forget md5 ; package require md5 2}
+
+ set fileToConstruct [lindex $copyinstructions 0]
+ set existingFile [lindex $copyinstructions 1]
+ set blockSize [lindex $copyinstructions 2]
+ array set fileStats [lindex $copyinstructions 3]
+ array set digestInstructionArray [DigestInstructionsExpand [lindex $copyinstructions 4] $blockSize]
+ array set dataInstructionArray [lindex $copyinstructions 5]
+ unset copyinstructions
+
+ if {[lsearch [file channels] $existingFile] == -1} {
+ set existingFile [FileNameNormalize $existingFile]
+ if {$fileToConstruct == {}} {file delete -force $existingFile ; return}
+ catch {
+ set existingID [open $existingFile r]
+ fconfigure $existingID -translation binary
+ }
+ } else {
+ set existingID $existingFile
+ fconfigure $existingID -translation binary
+ }
+
+ set temp $::trsync::temp
+
+ if {[lsearch [file channels] $fileToConstruct] == -1} {
+ set fileToConstruct [FileNameNormalize $fileToConstruct]
+ set constructTag "trsync.[md5::md5 -hex "[clock seconds] [clock clicks]"]"
+ set constructID [open $temp/$constructTag w]
+ } else {
+ set constructID $fileToConstruct
+ }
+ fconfigure $constructID -translation binary
+
+ if $eolNative {set eolNative [string is ascii -strict [array get dataInstructionArray]]}
+
+ set filePointer 1
+ while {$filePointer <= $fileStats(size)} {
+ if {[array names dataInstructionArray $filePointer] != {}} {
+ puts -nonewline $constructID $dataInstructionArray($filePointer)
+ set segmentLength [string length $dataInstructionArray($filePointer)]
+ array unset dataInstructionArray $filePointer
+ set filePointer [expr $filePointer + $segmentLength]
+ } elseif {[array names digestInstructionArray $filePointer] != {}} {
+ if ![info exists existingID] {error "Corrupt copy instructions."}
+ set blockNumber [lindex $digestInstructionArray($filePointer) 0]
+ set blockMd5Sum [lindex $digestInstructionArray($filePointer) 1]
+
+ seek $existingID [expr $blockNumber * $blockSize]
+
+ set existingBlock [read $existingID $blockSize]
+ set existingBlockMd5Sum [string range [md5::md5 -hex -- $existingBlock] 0 [expr [string length $blockMd5Sum] - 1]]
+ if ![string equal -nocase $blockMd5Sum $existingBlockMd5Sum] {error "digest file contents mismatch"}
+ puts -nonewline $constructID $existingBlock
+
+ if $eolNative {set eolNative [string is ascii -strict $existingBlock]}
+ unset existingBlock
+ set filePointer [expr $filePointer + $blockSize]
+ } else {
+ error "Corrupt copy instructions."
+ }
+ }
+ catch {close $existingID}
+ set fileStats(eolNative) $eolNative
+ if {[lsearch [file channels] $fileToConstruct] > -1} {return [array get fileStats]}
+
+ close $constructID
+
+ if $eolNative {
+ fcopy [set fin [open $temp/$constructTag r]] [set fout [open $temp/${constructTag}fcopy w]]
+ close $fin
+ close $fout
+ file delete -force $temp/$constructTag
+ set constructTag "${constructTag}fcopy"
+ }
+
+ catch {file attributes $temp/$constructTag -readonly 0} result
+ catch {file attributes $temp/$constructTag -permissions rw-rw-rw-} result
+ catch {file attributes $temp/$constructTag -owner $fileStats(uid)} result
+ catch {file attributes $temp/$constructTag -group $fileStats(gid)} result
+ catch {file mtime $temp/$constructTag $fileStats(mtime)} result
+ catch {file atime $temp/$constructTag $fileStats(atime)} result
+ if [string equal $fileToConstruct $existingFile] {
+ catch {file attributes $existingFile -readonly 0} result
+ catch {file attributes $existingFile -permissions rw-rw-rw-} result
+ }
+
+ Backup $backup $fileToConstruct
+
+ file mkdir [file dirname $fileToConstruct]
+ file rename -force $temp/$constructTag $fileToConstruct
+ array set attributes $fileStats(attributes)
+ array set attrConstruct [file attributes $fileToConstruct]
+ foreach attr [array names attributes] {
+ if [string equal [array get attributes $attr] [array get attrConstruct $attr]] {continue}
+ if {[string equal $attr "-longname"] || [string equal $attr "-shortname"] || [string equal $attr "-permissions"]} {continue}
+ catch {file attributes $fileToConstruct $attr $attributes($attr)} result
+ }
+ catch {file attributes $fileToConstruct -permissions $fileStats(mode)} result
+ return
+}
+
+proc CopyInstructions {filename digest} {
+ if [catch {package present md5 2}] {package forget md5 ; package require md5 2}
+
+ if {[lsearch [file channels] $filename] == -1} {
+ set filename [FileNameNormalize $filename]
+ file stat $filename fileStats
+ array set fileAttributes [file attributes $filename]
+ array unset fileAttributes -longname
+ array unset fileAttributes -shortname
+ set arrayadd attributes ; lappend arrayadd [array get fileAttributes] ; array set fileStats $arrayadd
+ set f [open $filename r]
+ } else {
+ set f $filename
+ set fileStats(attributes) {}
+ }
+ fconfigure $f -translation binary
+ seek $f 0 end
+ set fileSize [tell $f]
+ seek $f 0
+ set fileStats(size) $fileSize
+ set digestFileName [lindex $digest 0]
+ set blockSize [lindex $digest 1]
+ set digest [lrange $digest 2 end]
+
+ if {[lsearch -exact $digest fingerprints] > -1} {
+ set fingerPrints [lindex $digest end]
+ set digest [lrange $digest 0 end-2]
+ set fileContents [read $f]
+ set matchCount 0
+ foreach fP $fingerPrints {
+ if {[string first $fP $fileContents] > -1} {incr matchCount}
+ if {$matchCount > 3} {break}
+ }
+ unset fileContents
+ seek $f 0
+ if {$matchCount < 3} {set digest {}}
+ }
+
+ set digestLength [llength $digest]
+ for {set i 0} {$i < $digestLength} {incr i} {
+ set arrayadd [lindex [lindex $digest $i] 1]
+ lappend arrayadd $i
+ array set Checksums $arrayadd
+ }
+ set digestInstructions {}
+ set dataInstructions {}
+ set weakChecksum {}
+ set startBlockPointer 0
+ set endBlockPointer 0
+
+ if ![array exists Checksums] {
+ set dataInstructions 1
+ lappend dataInstructions [read $f]
+ set endBlockPointer $fileSize
+ }
+
+ while {$endBlockPointer < $fileSize} {
+ set endBlockPointer [expr $startBlockPointer + $blockSize]
+ incr startBlockPointer
+ if {$weakChecksum == {}} {
+ set blockContents [read $f $blockSize]
+ set blockNumberSequence [SequenceBlock $blockContents]
+ set weakChecksumInfo [WeakChecksum $blockNumberSequence]
+ set weakChecksum [format %.0f [lindex $weakChecksumInfo 0]]
+ set startDataPointer $startBlockPointer
+ set endDataPointer $startDataPointer
+ set dataBuffer {}
+ }
+ if {[array names Checksums $weakChecksum] != {}} {
+ set md5Sum [md5::md5 -hex -- $blockContents]
+ set blockIndex $Checksums($weakChecksum)
+ set digestmd5Sum [lindex [lindex $digest $blockIndex] 0]
+ if [string equal -nocase $digestmd5Sum $md5Sum] {
+ if {$endDataPointer > $startDataPointer} {
+ lappend dataInstructions $startDataPointer
+ lappend dataInstructions $dataBuffer
+ }
+ lappend digestInstructions $startBlockPointer
+ lappend digestInstructions "$blockIndex [string range $md5Sum 0 [expr $::trsync::md5Size - 1]]"
+ set weakChecksum {}
+ set startBlockPointer $endBlockPointer
+ continue
+ }
+ }
+ if {$endBlockPointer >= $fileSize} {
+ lappend dataInstructions $startDataPointer
+ lappend dataInstructions $dataBuffer$blockContents
+ break
+ }
+ set rollChar [read $f 1]
+ binary scan $rollChar c* rollNumber
+ set rollNumber [expr ($rollNumber + 0x100)%0x100]
+ lappend blockNumberSequence $rollNumber
+ set blockNumberSequence [lrange $blockNumberSequence 1 end]
+
+ binary scan $blockContents a1a* rollOffChar blockContents
+ set blockContents $blockContents$rollChar
+ set dataBuffer $dataBuffer$rollOffChar
+ incr endDataPointer
+
+ set weakChecksumInfo "[eval RollChecksum [lrange $weakChecksumInfo 1 5] $rollNumber] [lindex $blockNumberSequence 0]"
+ set weakChecksum [format %.0f [lindex $weakChecksumInfo 0]]
+ }
+ close $f
+
+ lappend copyInstructions $filename
+ lappend copyInstructions $digestFileName
+ lappend copyInstructions $blockSize
+ lappend copyInstructions [array get fileStats]
+ lappend copyInstructions [DigestInstructionsCompress $digestInstructions $blockSize]
+ lappend copyInstructions $dataInstructions
+ return $copyInstructions
+}
+
+proc Digest {filename blockSize {sizecheck 0} {fingerprint 0}} {
+ if [catch {package present md5 2}] {package forget md5 ; package require md5 2}
+
+ set digest "[list $filename] $blockSize"
+ if {[lsearch [file channels] $filename] == -1} {
+ set filename [FileNameNormalize $filename]
+ set digest "[list $filename] $blockSize"
+ if {!([file isfile $filename] && [file readable $filename])} {return $digest}
+ set f [open $filename r]
+ } else {
+ set f $filename
+ }
+ fconfigure $f -translation binary
+ seek $f 0 end
+ set fileSize [tell $f]
+ seek $f 0
+ if {$sizecheck && ($fileSize < [expr $blockSize * 5])} {close $f ; return $digest}
+
+ while {![eof $f]} {
+ set blockContents [read $f $blockSize]
+ set md5Sum [md5::md5 -hex -- $blockContents]
+ set blockNumberSequence [SequenceBlock $blockContents]
+ set weakChecksum [lindex [WeakChecksum $blockNumberSequence] 0]
+ lappend digest "$md5Sum [format %.0f $weakChecksum]"
+ }
+ if $fingerprint {
+ set fileIncrement [expr $fileSize/10]
+ set fpLocation [expr $fileSize - 21]
+ set i 0
+ while {$i < 10} {
+ if {$fpLocation < 0} {set fpLocation 0}
+ seek $f $fpLocation
+ lappend fingerPrints [read $f 20]
+ set fpLocation [expr $fpLocation - $fileIncrement]
+ incr i
+ }
+ lappend digest fingerprints
+ lappend digest [lsort -unique $fingerPrints]
+ }
+ close $f
+ return $digest
+}
+
+proc DigestInstructionsCompress {digestInstructions blockSize} {
+ if [string equal $digestInstructions {}] {return {}}
+ set blockSpan $blockSize
+ foreach {pointer blockInfo} $digestInstructions {
+ if ![info exists currentBlockInfo] {
+ set currentPointer $pointer
+ set currentBlockInfo $blockInfo
+ set md5Size [string length [lindex $blockInfo 1]]
+ continue
+ }
+ if {$pointer == [expr $currentPointer + $blockSpan]} {
+ set md5 [lindex $blockInfo 1]
+ lappend currentBlockInfo $md5
+ incr blockSpan $blockSize
+ } else {
+ lappend newDigestInstructions $currentPointer
+ lappend newDigestInstructions "[lindex $currentBlockInfo 0] [list "$md5Size [string map {{ } {}} [lrange $currentBlockInfo 1 end]]"]"
+
+ set currentPointer $pointer
+ set currentBlockInfo $blockInfo
+ set blockSpan $blockSize
+ }
+ }
+ lappend newDigestInstructions $currentPointer
+ lappend newDigestInstructions "[lindex $currentBlockInfo 0] [list "$md5Size [string map {{ } {}} [lrange $currentBlockInfo 1 end]]"]"
+ return $newDigestInstructions
+}
+
+proc DigestInstructionsExpand {digestInstructions blockSize} {
+ if [string equal $digestInstructions {}] {return {}}
+ foreach {pointer blockInfo} $digestInstructions {
+ set blockNumber [lindex $blockInfo 0]
+ set md5Size [lindex [lindex $blockInfo 1] 0]
+ set blockString [lindex [lindex $blockInfo 1] 1]
+ set blockLength [string length $blockString]
+
+ set expandedBlock {}
+ for {set i $md5Size} {$i <= $blockLength} {incr i $md5Size} {
+ append expandedBlock " [string range $blockString [expr $i - $md5Size] [expr $i - 1]]"
+ }
+
+ set blockInfo "$blockNumber $expandedBlock"
+ foreach md5 [lrange $blockInfo 1 end] {
+ lappend newDigestInstructions $pointer
+ lappend newDigestInstructions "$blockNumber $md5"
+ incr pointer $blockSize
+ incr blockNumber
+ }
+ }
+ return $newDigestInstructions
+}
+
+proc FileNameNormalize {filename} {
+ file normalize $filename
+}
+
+proc RollChecksum {a(k,l)_ b(k,l)_ k l Xsub_k Xsub_l+1 } {
+ set Mod $trsync::Mod
+
+ set a(k+1,l+1)_ [expr ${a(k,l)_} - $Xsub_k + ${Xsub_l+1}]
+ set b(k+1,l+1)_ [expr ${b(k,l)_} - (($l - $k + 1) * $Xsub_k) + ${a(k+1,l+1)_}]
+
+ set a(k+1,l+1)_ [expr fmod(${a(k+1,l+1)_},$Mod)]
+ set b(k+1,l+1)_ [expr fmod(${b(k+1,l+1)_},$Mod)]
+ set s(k+1,l+1)_ [expr ${a(k+1,l+1)_} + ($Mod * ${b(k+1,l+1)_})]
+ return "${s(k+1,l+1)_} ${a(k+1,l+1)_} ${b(k+1,l+1)_} [incr k] [incr l]"
+}
+
+proc SequenceBlock {blockcontents} {
+ binary scan $blockcontents c* blockNumberSequence
+ set blockNumberSequenceLength [llength $blockNumberSequence]
+ for {set i 0} {$i < $blockNumberSequenceLength} {incr i} {
+ set blockNumberSequence [lreplace $blockNumberSequence $i $i [expr ([lindex $blockNumberSequence $i] + 0x100)%0x100]]
+ }
+ return $blockNumberSequence
+}
+
+proc WeakChecksum {Xsub_k...Xsub_l} {
+ set a(k,i)_ 0
+ set b(k,i)_ 0
+ set Mod $trsync::Mod
+ set k 1
+ set l [llength ${Xsub_k...Xsub_l}]
+ for {set i $k} {$i <= $l} {incr i} {
+ set Xsub_i [lindex ${Xsub_k...Xsub_l} [expr $i - 1]]
+ set a(k,i)_ [expr ${a(k,i)_} + $Xsub_i]
+ set b(k,i)_ [expr ${b(k,i)_} + (($l - $i + 1) * $Xsub_i)]
+ }
+ set a(k,l)_ [expr fmod(${a(k,i)_},$Mod)]
+ set b(k,l)_ [expr fmod(${b(k,i)_},$Mod)]
+ set s(k,l)_ [expr ${a(k,l)_} + ($Mod * ${b(k,l)_})]
+ return "${s(k,l)_} ${a(k,l)_} ${b(k,l)_} $k $l [lindex ${Xsub_k...Xsub_l} 0]"
+}
+
+proc tdelta {referenceFile targetFile blockSize {sizecheck 0} {fingerprint 0}} {
+ if {$::trsync::md5Size < 1} {error "md5Size must be greater than zero."}
+ set signature [Digest $targetFile $blockSize $sizecheck $fingerprint]
+ return [CopyInstructions $referenceFile $signature]
+}
+
+proc tpatch {targetFile copyInstructions fileToConstruct {eolNative 0}} {
+ set copyInstructions [lreplace $copyInstructions 0 1 $fileToConstruct $targetFile]
+ return [ConstructFile $copyInstructions $eolNative]
+}
+
+namespace export tdelta tpatch
+
+}
+# end namespace eval ::trsync
+
--- /dev/null
+#/usr/bin/env tclsh
+
+if 0 {
+########################
+
+templatevfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.0
+
+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
+vfs, requiring no knowledge of the Tclvfs API.
+
+In addition, several behind-the-scenes functions are provided to make new vfs's more stable and
+scalable, including file information caching and management of close callback errors.
+
+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>
+
+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
+value is viewable and editable after mount by calling "file attributes <virtual directory> -cache ?value?"
+
+-volume
+Volume specified in virtual directory pathname will be mounted as a virtual volume.
+
+The above options are inherited by all virtual filesystems built using the template.
+
+Side effects: Files whose names begin with ".vfs_" will be ignored and thus invisible to the
+user unless the variable ::vfs::template::vfs_retrieve exists.
+
+Sourcing this file will run code that overloads the exit command with
+a procedure that ensures that all vfs's are explicitly unmounted before the
+shell terminates.
+
+When a vfs built on the template vfs is mounted, the mount command options are stored in an array named
+vfs::template::mount with the virtual mount points as the array index name. On exit, the contents of
+this array are stored in the file $HOME/.vfs_tcl. When this file is sourced, the array vfs::template::mount
+is restored by reading $HOME/.vfs_tcl if the file exists.
+
+########################
+}
+
+package require vfs 1.0
+
+package provide vfs::template 1.0
+
+namespace eval ::vfs::template {
+
+if 0 {
+########################
+
+In order to create a new virtual filesystem:
+
+1. copy the contents of this namespace eval statement to a
+new namespace eval statement with a unique new namespace defined
+
+2. rewrite the copied procedures to retrieve and handle virtual filesystem
+information as desired and return it in the same format as the given native
+file commands.
+
+########################
+}
+
+package require vfs::template
+
+# 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
+}
+
+# edit following procedures:
+
+# Do not close channel within this procedure (will cause error). Simply
+# read info from channel as needed and return.
+proc close_ {channel} {return}
+
+# Variable $time is always defined. These procs only set time values.
+proc file_atime {file time} {file atime $file $time}
+proc file_mtime {file time} {file mtime $file $time}
+
+# Variables $attribute and $args may or may not be empty.
+# If $attribute is empty so is $args (retrieve all attributes and values).
+# If $args only is empty, retrieve value of specified attribute.
+# If $args has a value, set it as value of specified attribute.
+proc file_attributes {file {attribute {}} args} {eval file attributes \$file $attribute $args}
+
+# Variable $file may be a file or directory.
+# This proc only called if it is certain that deletion is the correct action.
+proc file_delete {file} {file delete -force -- $file}
+
+proc file_executable {file} {file executable $file}
+proc file_exists {file} {file exists $file}
+proc file_mkdir {file} {file mkdir $file}
+proc file_readable {file} {file readable $file}
+proc file_stat {file array} {upvar $array fs ; file stat $file fs}
+proc file_writable {file} {file writable $file}
+
+# All variables are always defined.
+# Return list of filenames only, not full pathnames.
+proc glob_ {directory dir nocomplain tails types typeString dashes pattern} {glob -directory $dir -nocomplain -tails -types $typeString -- $pattern}
+proc open_ {file mode} {open $file $mode}
+
+
+# MountProcedure is called once each time a vfs is newly mounted.
+proc MountProcedure {args} {
+ upvar volume volume
+
+# take real and virtual directories from command line args.
+ set to [lindex $args end]
+ if [string equal $volume {}] {set to [::file normalize $to]}
+ set path [::file normalize [lindex $args end-1]]
+
+# make sure mount location exists:
+ ::file mkdir $path
+
+# add custom handling for new vfs args here.
+
+# return two-item list consisting of real and virtual locations.
+ lappend pathto $path
+ lappend pathto $to
+ return $pathto
+}
+
+
+proc UnmountProcedure {path to} {
+# add custom unmount handling of new vfs elements here.
+
+ return
+}
+
+}
+# end namespace ::vfs::template
+
+
+# Below are template API procedures; there should be no need to edit them.
+
+namespace eval ::vfs::template {
+
+proc Mount {args} {
+
+# handle template command line args:
+ set volume [lindex $args [lsearch $args "-volume"]]
+ set cache 2
+ if {[set cacheIndex [lsearch $args "-cache"]] != -1} {set cache [lindex $args [incr cacheIndex]]}
+ set args [string map "\" -volume \" { } \" -cache $cache \" { }" " $args "]
+# run unmount procedure if mount exists:
+ set to [lindex $args end]
+ if [info exists ::vfs::_unmountCmd($to)] {$::vfs::_unmountCmd($to) $to}
+
+# call custom mount procedure:
+ # 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
+ unset -nocomplain ::vfs::template::vfs_retrieve
+
+ set path [lindex $pathto 0]
+ set to [lindex $pathto 1]
+ 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"
+
+# if virtual location still mounted, unmount it by force:
+ if {[lsearch [::vfs::filesystem info] $to] != -1} {::vfs::filesystem unmount $to}
+ array unset ::vfs::_unmountCmd $to
+
+# set file info cache dwell time value:
+ set [namespace current]::cache($to) $cache
+
+# register location with Tclvfs package:
+ eval ::vfs::filesystem mount $volume \$to \[list [namespace current]::handler \$path\]
+ ::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
+ trace remove execution ::file leave ::vfs::template::FileTrace
+ trace add execution ::close leave vfs::template::CloseTrace
+ trace add execution ::file leave vfs::template::FileTrace
+
+ return $to
+}
+
+# undo Tclvfs API hooks:
+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
+
+ ::vfs::filesystem unmount $to
+ array unset ::vfs::_unmountCmd [::file normalize $to]
+
+# clear file info caches:
+ CacheClear $to
+}
+
+# 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]
+ 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
+ CacheClear $virtualName
+ }
+ deletefile {
+ DeleteFile $path $root $relative $actualpath
+ CacheClear $virtualName
+ }
+ fileattributes {
+ set index [lindex $args 0]
+ set value [lindex $args 1]
+ set extra {}
+ if [string equal $relative {}] {eval set extra \"-cache \$[namespace current]::cache(\$root)\"}
+
+ # try to get values from cache first:
+ array set attributes [CacheGet [namespace current]::attributes $virtualName [set [namespace current]::cache($root)]]
+ # if not in cache, get them from file:
+ if [string equal [array get attributes] {}] {
+ array set attributes "[FileAttributes $path $root $relative $actualpath] $extra"
+ CacheSet [namespace current]::attributes $virtualName [array get attributes]
+ }
+
+ set attribute [lindex [lsort [array names attributes]] $index]
+
+ # if value given in args, set it and return:
+ if ![string equal $value {}] {
+ if [string equal $attribute "-cache"] {
+ set [namespace current]::cache($root) $value
+ } else {
+ FileAttributesSet $path $root $relative $actualpath $attribute $value
+ }
+ CacheClear $virtualName
+ return
+ }
+
+ # if attribute give in args, return its value:
+ if ![string equal $index {}] {
+ return $attributes($attribute)
+ }
+
+ # otherwise, just return all attribute names
+ return [lsort [array names attributes]]
+ }
+ matchindirectory {
+ set pattern [lindex $args 0]
+ set types [lindex $args 1]
+ return [MatchInDirectory $path $root $relative $actualpath $pattern $types]
+ } open {
+ # ensure files named ".vfs_*" can't be opened ordinarily:
+ if {![string first ".vfs_" [file tail $relative]] && ![info exists ::vfs::template::vfs_retrieve]} {vfs::filesystem posixerror $::vfs::posix(EACCES)}
+
+ set mode [lindex $args 0]
+ if {$mode == {}} {set mode r}
+
+ # workaround: Tclvfs can't handle channels in write-only modes; see Tclvfs bug #1004273
+ if {$mode == "w"} {set mode w+}
+ if {$mode == "a"} {set mode a+}
+
+ set permissions [lindex $args 1]
+ set channelID [Open $path $root $relative $actualpath $mode $permissions]
+
+ # ensure channel settings match file command defaults
+ set eofChar {{} {}}
+ if [string equal $::tcl_platform(platform) "windows"] {set eofChar "\x1a {}"}
+ fconfigure $channelID -encoding [encoding system] -eofchar $eofChar -translation auto
+ 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
+ # designate handler as close callback command
+ lappend result [list [namespace current]::handler $path close $root $relative $actualpath $channelID $mode]
+
+
+ # make sure all interpreters can catch errors in close callback:
+ foreach int [interp slaves] {
+ InterpSeed $int
+ }
+
+ CacheClear $virtualName
+ return $result
+ } close {
+ set channelID [lindex $args 0]
+ 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]
+ if $err {::vfs::template::closeerror $::errorInfo ; error $::errorInfo}
+ return
+ }
+ removedirectory {
+ 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)
+ }
+ }
+ RemoveDirectory $path $root $relative $actualpath
+ CacheClear $virtualName
+ }
+ stat {
+ set stat [CacheGet [namespace current]::stat $virtualName [set [namespace current]::cache($root)]]
+ if ![string equal $stat ""] {
+ return $stat
+ }
+ set stat [Stat $path $root $relative $actualpath]
+ CacheSet [namespace current]::stat $virtualName $stat
+ return $stat
+ }
+ utime {
+ set atime [lindex $args 0]
+ set mtime [lindex $args 1]
+ Utime $path $root $relative $actualpath $atime $mtime
+ array unset [namespace current]::stat $virtualName,time ; array unset [namespace current]::stat $virtualName,value
+ }
+ }
+}
+
+# following commands carry out information processing requirements for each vfshandler subcommand:
+# note that all calls to file commands are redirected to simplified API procs at top of this script
+
+proc Access {path root relative actualpath mode} {
+ set fileName [::file join $path $relative]
+ set virtualName [::file join $root $relative]
+ set modeString [::vfs::accessMode $mode]
+ set modeString [split $modeString {}]
+ set modeString [string map "F exists R readable W writable X executable" $modeString]
+ set secs [clock seconds]
+ 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]
+ CacheSet [namespace current]::$mode $virtualName $result $secs
+ }
+ if !$result {error error}
+ }
+ return
+}
+
+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 -force -- $fileName
+}
+
+proc FileAttributes {path root relative actualpath} {
+ set fileName [::file join $path $relative]
+ return [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} {
+# special case: check for existence (see Tclvfs bug #1405317)
+ if [string equal $pattern {}] {
+ if ![::vfs::matchDirectories $types] {return {}}
+ return [::file join $root $relative]
+ }
+
+# convert types bitstring back to human-readable alpha string:
+ foreach {type shift} {b 0 c 1 d 2 p 3 f 4 l 5 s 6} {
+ if [expr {$types == 0 ? 1 : $types & (1<<$shift)}] {lappend typeString $type}
+ }
+ set pathName [::file join $path $relative]
+
+# get non-hidden files:
+ 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]"}
+
+# convert real path to virtual path:
+ set newGlobList {}
+ foreach gL $globList {
+ if {![string first ".vfs_" $gL] && ![info exists ::vfs::template::vfs_retrieve]} {continue}
+ set gL [::file join $root $relative $gL]
+ lappend newGlobList $gL
+ }
+ set newGlobList [lsort -unique $newGlobList]
+ 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}
+ 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
+}
+
+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
+}
+
+# check value of ::errorInfo to ensure close callback didn't generate background
+# error; if it did, force error break.
+proc CloseTrace {commandString code result op} {
+ if {[info exists ::vfs::template::vfs_error] && ($::vfs::template::vfs_error != {})} {
+ set vfs_error $::vfs::template::vfs_error
+ closeerror {}
+ error $vfs_error
+ }
+ return
+}
+
+# file copy and file rename may trigger close callbacks internally, so check for close errors
+# after these commands complete.
+proc FileTrace {commandString code result op} {
+ if {[string map {copy {} rename {}} [lindex $commandString 1]] != {}} {return}
+ if {[info exists ::vfs::template::vfs_error] && ($::vfs::template::vfs_error != {})} {
+ set vfs_error $::vfs::template::vfs_error
+ closeerror {}
+ error $vfs_error
+ }
+ return
+}
+
+# ensure ::errorInfo from background errors makes it into every child interpreter
+# so CloseTrace and FileTrace can intercept it.
+
+proc closeerror {errorInfo} {
+ set ::vfs::template::vfs_error $errorInfo
+ foreach int [interp slaves] {
+ InterpSeed $int set ::vfs::template::vfs_error $::vfs::template::vfs_error
+ }
+}
+
+# seed all interpreters with trace structures necessary to intercept close callback errors:
+proc InterpSeed {interp args} {
+ interp eval $interp {namespace eval ::vfs::template {}}
+ $interp alias ::vfs::template::closeerror ::vfs::template::closeerror
+ $interp alias ::vfs::template::FileTrace ::vfs::template::FileTrace
+ $interp alias ::vfs::template::CloseTrace ::vfs::template::CloseTrace
+ interp eval $interp trace remove execution ::file leave ::vfs::template::FileTrace
+ interp eval $interp trace remove execution ::close leave ::vfs::template::CloseTrace
+
+ interp eval $interp trace add execution ::close leave ::vfs::template::CloseTrace
+ interp eval $interp trace add execution ::file leave ::vfs::template::FileTrace
+
+ interp eval $interp $args
+ foreach int [interp slaves $interp] {
+ InterpSeed $int $args
+ }
+}
+
+# cache management functions:
+proc CacheClear {file} {
+ foreach arr {exists readable writable executable stat attributes} {
+ array unset [namespace current]::$arr $file,time
+ array unset [namespace current]::$arr $file,value
+ array unset [namespace current]::$arr $file/*
+ }
+}
+
+proc CacheGet {array file cache args} {
+ if [string equal [array names $array $file,time] {}] {return}
+ if ![string equal $args {}] {set secs $args} else {set secs [clock seconds]}
+ set fileTime [lindex [array get $array $file,time] 1]
+ if {[expr $secs - $fileTime] < $cache} {return [lindex [array get $array $file,value] 1]}
+ array unset $array $file,time ; array unset $array $file,value
+ return
+}
+
+proc CacheSet {array file value args} {
+ if ![string equal $args {}] {set secs $args} else {set secs [clock seconds]}
+ set fileTime $file,time
+ array set $array [list $fileTime $secs]
+ set fileValue $file,value
+ array set $array [list $fileValue $value]
+}
+
+}
+# 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 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 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
+
+
+# overload exit command so that all vfs's are explicitly
+# unmounted before program termination:
+
+catch {rename ::exit ::vfs::template::exit}
+
+proc ::exit {} {
+ foreach vfs [lsort -decreasing [::vfs::filesystem info]] {
+ if [catch {$::vfs::_unmountCmd($vfs) $vfs} result] {
+ puts "$vfs: $result"
+ }
+ }
+
+ # save contents of array which stores historical mount command options
+ if [info exists ::vfs::template::mount] {
+ set startDir [pwd]
+ cd
+ set f [open .vfs_tcl w]
+ puts $f [array get ::vfs::template::mount]
+ close $f
+ cd $startDir
+ }
+ ::vfs::template::exit
+}
+
+# restore mount command options history to array:
+if [file exists .vfs_tcl] {
+ set startDir [pwd]
+ cd
+ set f [open .vfs_tcl r]
+ array set ::vfs::template::mount [read $f]
+ close $f
+ cd $startDir
+}
+
--- /dev/null
+if 0 {
+########################
+
+versionvfs.tcl --
+
+Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
+License: Tcl license
+Version 1.0
+
+A versioning virtual filesystem. Requires the template vfs in templatevfs.tcl.
+
+Similar to historical versioning filesystems, each edited version of a file is saved separately;
+each version file is tagged with a timestamp, and optional project tags.
+A deleted file is represented by a new zero-length file with timestamp and a tag reading "deleted".
+By default only the latest version is visible. If the latest version is marked deleted, it is invisible.
+
+Directories are versioned and tagged in the same way as files.
+
+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>
+
+Options:
+
+-keep
+maximum number of previous versions of a file to keep per project.
+
+-project
+a list of one or more version-identifying tags. Any file created or edited in the virtual file space
+will be given these tags. File versions with a tag matching the ones given here will be visible in
+preference to other, possibly later versions without the tag.
+
+If a file version has project tags but none of them is included in this project tag list, it will be
+invisible; the file itself will then be invisible unless a file version exists without any
+project tags, in which case it will be treated as the default.
+
+In cases where several file versions each have multiple tags that match in the project
+list, the version with the greatest number of matches will be visible.
+
+Deleted files are marked with the tag "deleted". If this value is in the project
+name list, then deleted files will become visible again.
+
+Newly-created and deleted directories are tagged and shown/hidden in the same way as files.
+
+-time
+A timestamp in the form returned by [clock seconds], or a string understandable by [clock scan].
+Versions of files as they existed at the given time will be visible, rather than the
+default latest version. Version choices based on project tags will still be made, but
+versions later than the timestamp will be ignored in the decision process.
+
+
+The values of each option can be changed dynamically after mount by using the "file attributes"
+command on the mount virtual directory. Each option is editable as an attribute;
+i.e., "file attributes C:/version -project {version2 release}". Display of visible files will
+change dynamically based on decisions with new attribute values.
+
+In addition, new attributes are defined which can be queried for individual files:
+
+The command "file attributes $file -version_filename" will show the exact filename of the
+currently visible version of the given file as it is stored in the vfs, complete with
+timestamp and project tags if any.
+
+The command "file attributes $file -versions" will return a list containing information on
+all stored versions of the given file. Each element of the list is itself a three-element
+list: 1) the unique millisecond-level timestamp of the version, 2) a human-readable date string
+showing the time represented by the timestamp (can be used a a value for the -time attribute),
+and 3) a list of the project tags attached to the version, if any.
+
+The versioning vfs inherits the -cache and -volume options of the template vfs.
+
+########################
+}
+
+package provide vfs::template::version 1.0
+
+package require vfs::template
+
+namespace eval ::vfs::template::version {
+
+# 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
+}
+
+# edit following procedures:
+proc close_ {channelID} {
+ upvar path path root root relative relative
+
+# get hash of file as it existed before edit:
+ array set fileStats $::vfs::template::version::filestats($channelID)
+ unset ::vfs::template::version::filestats($channelID)
+
+# if new hash shows file is unchanged, return immediately:
+ fconfigure $channelID -translation binary
+ set hash [Hash $channelID]
+ if [string equal -nocase $hash $fileStats(hash)] {return}
+
+# create new unique filename for new version:
+ set fileName [VFileNameEncode [file join $path $relative]]\;[VCreateTag $root]
+ catch {array set oldAttributes [file attributes $fileStats(filename)]}
+
+# delete file version created by open_ if it's a new file:
+ if [string equal $fileStats(hash) {}] {
+ file delete $fileStats(filename)
+ }
+
+# save new version:
+ set f [open $fileName w]
+ fconfigure $f -translation binary
+ seek $channelID 0
+ fcopy $channelID $f
+ close $f
+
+# ensure attributes are the same for new version:
+ foreach {attr value} [file attributes $fileName] {
+ if ![info exists oldAttributes($attr)] {continue}
+ if {$oldAttributes($attr) != $value} {catch {file attributes $fileName $attr $oldAttributes($attr)}}
+ }
+
+ return
+}
+proc file_atime {file time} {
+ upvar path path root root relative relative
+# check if current version is latest, if not disallow edit:
+ set latest [lindex [lindex [lsort [VersionsAll $path $relative]] end] 0]
+ set acquired [lindex [split [set fileName [VAcquireFile $path $root $relative]] \;] 1]
+ if ![string first .&dir [file tail $fileName]] {::vfs::filesystem posixerror $::vfs::posix(ENOENT)}
+ if {($acquired != {}) && ($latest != $acquired)} {::vfs::filesystem posixerror $::vfs::posix(EPERM)}
+
+ file atime $fileName $time
+}
+proc file_mtime {file time} {
+ upvar path path root root relative relative
+# check if current version is latest, if not disallow edit:
+ set latest [lindex [lindex [lsort [VersionsAll $path $relative]] end] 0]
+ set acquired [lindex [split [set fileName [VAcquireFile $path $root $relative]] \;] 1]
+ if ![string first .&dir [file tail $fileName]] {::vfs::filesystem posixerror $::vfs::posix(ENOENT)}
+ if {($acquired != {}) && ($latest != $acquired)} {::vfs::filesystem posixerror $::vfs::posix(EPERM)}
+
+ file mtime $fileName $time
+}
+proc file_attributes {file {attribute {}} args} {
+ upvar path path root root relative relative
+ set latest [lindex [lindex [lsort [set allVersions [VersionsAll $path $relative]]] end] 0]
+ set acquired [lindex [split [set fileName [VAcquireFile $path $root $relative]] \;] 1]
+ if ![string first .&dir [file tail $fileName]] {::vfs::filesystem posixerror $::vfs::posix(ENOENT)}
+
+# process vfs-specific attributes:
+ if {($relative == {}) && ([string map {-keep 1 -project 1 -time 1} $attribute] == 1)} {
+ set attribute [string range $attribute 1 end]
+ if {$args == {}} {
+ if ![info exists ::vfs::template::version::${attribute}($root)] {return}
+ eval return \$::vfs::template::version::${attribute}(\$root)
+ }
+ set ::vfs::template::version::${attribute}($root) [lindex $args 0]
+ if {[lindex $args 0] == {{}}} {unset ::vfs::template::version::${attribute}($root)}
+ return
+ }
+ # process read-only vfs-specific attributes:
+ if {$attribute == "-versions"} {
+ if {$args == {}} {return $allVersions}
+ error "cannot set attribute \"-versions\" for file \"[file tail $relative]\": attribute is readonly"
+ }
+ if {$attribute == "-version_filename"} {
+ if {$args == {}} {return [file tail $fileName]}
+ error "cannot set attribute \"-version_filename\" for file \"[file tail $relative]\": attribute is readonly"
+ }
+
+# check if current version is latest, if not disallow edit:
+ if {($args != {}) && ($acquired != {}) && ($latest != $acquired)} {::vfs::filesystem posixerror $::vfs::posix(EPERM)}
+ set returnValue [eval file attributes \$fileName $attribute $args]
+
+# collect values for vfs-specific attributes:
+ if {$attribute == {}} {
+ append returnValue " [list -versions $allVersions]"
+ if {$file != $fileName} {append returnValue " [list -version_filename [file tail $fileName]]"}
+ if {$relative != {}} {return $returnValue}
+ foreach atr "keep project time" {
+ set $atr "-$atr {}"
+ if [info exists ::vfs::template::version::${atr}($root)] {eval set $atr \[list "-$atr" \$::vfs::template::version::${atr}(\$root)\]}
+ }
+ append returnValue " $keep $project $time"
+ }
+ return $returnValue
+}
+proc file_delete {file} {
+ upvar path path root root relative relative
+ set dir 0
+ if [file isdirectory $file] {set dir 1}
+ set fileName [VAcquireFile $path $root $relative]
+
+# allow straight deletion of new zero-length file:
+ if {!$dir && ([llength [VersionsAll $path $relative]] == 1) && ![file size $fileName]} {
+ file delete -force $fileName
+ return
+ }
+
+# for all others, create new file with "deleted" tag
+ set file [VFileNameEncode $file]
+ set fileName $file\;[VCreateTag $root]
+ if $dir {set fileName [file join $file .&dir[file tail $file]]\;[VCreateTag $root]}
+ set fileName [split $fileName \;]
+ set fileName [linsert $fileName 2 "deleted"]
+ set fileName [join $fileName \;]
+ close [open $fileName w]
+ if $dir {catch {file attributes $fileName -hidden 1}}
+}
+proc file_executable {file} {
+ upvar path path root root relative relative
+ set fileName [VAcquireFile $path $root $relative]
+ file executable $fileName
+}
+proc file_exists {file} {
+ upvar path path root root relative relative
+ set fileName [VAcquireFile $path $root $relative]
+ file exists $fileName
+}
+proc file_mkdir {file} {
+ upvar root root
+ file mkdir $file
+
+# create a file to store timestamps and tags for directory:
+ set fileName [VFileNameEncode $file]
+ set fileName [file join $fileName .&dir[file tail $fileName]]\;[VCreateTag $root]
+ close [open $fileName w]
+ catch {file attributes $fileName -hidden 1}
+ return
+}
+proc file_readable {file} {
+ upvar path path root root relative relative
+ set fileName [VAcquireFile $path $root $relative]
+ file readable $fileName
+}
+proc file_stat {file array} {
+ upvar path path root root relative relative $array fs
+ set fileName [VAcquireFile $path $root $relative]
+ if ![string first .&dir [file tail $fileName]] {error "no such file or directory"}
+ file stat $fileName fs
+ if {$fs(type) == "directory"} {
+ return
+ }
+ if {$fileName == [file join $path $relative]} {error "no such file or directory"}
+ return
+}
+proc file_writable {file} {
+ upvar path path root root relative relative
+ set fileName [VAcquireFile $path $root $relative]
+ file writable $fileName
+}
+proc glob_ {directory dir nocomplain tails types typeString dashes pattern} {
+ upvar path path root root relative relative
+ set globList [glob -directory $dir -nocomplain -types $typeString *]
+ set newGlobList {}
+ set acquireAttempts {}
+ foreach gL $globList {
+ if [file isdirectory $gL] {
+ set acquiredFile [VAcquireFile $path $root [file join $relative [file tail $gL]]]
+ if ![string equal $acquiredFile $gL] {continue}
+ } else {
+ if ![string first .&dir [file tail $gL]] {continue}
+ set gL [VFileNameDecode $gL]
+ if {[lsearch $acquireAttempts $gL] > -1} {continue}
+ lappend acquireAttempts $gL
+ set acquiredFile [VAcquireFile $path $root [file join $relative [file tail $gL]]]
+ if [string equal $acquiredFile $gL] {continue}
+ }
+ if [string match $pattern [file tail $gL]] {lappend newGlobList [file tail $gL]}
+ }
+ return $newGlobList
+}
+proc open_ {file mode} {
+ upvar path path root root relative relative
+ set fileName [VAcquireFile $path $root $relative]
+ if {$mode == "r"} {return [open $fileName r]}
+ set hash {}
+
+# Use memchans so if file contents don't change we are free to delete file rather than commit to
+# creating new version which is identical to last.
+# If file is new, create new tag for it and return memchan:
+ if {$fileName == [file join $path $relative]} {
+ set fileName [VFileNameEncode [file join $path $relative]]\;[VCreateTag $root]
+ close [open $fileName $mode]
+ set channelID [vfs::memchan]
+ set ::vfs::template::version::filestats($channelID) "filename [list $fileName] hash [list $hash]"
+ return $channelID
+ }
+
+# otherwise, get hash of existing file and store it where close callback can grab it,
+# then return memchan:
+ set f [open $fileName r]
+ fconfigure $f -translation binary
+ set hash [Hash $f]
+ close $f
+ set filed [vfs::memchan]
+ if {[string index $mode 0] == "a"} {
+ set f [open $fileName r]
+ fconfigure $f -translation binary
+ fconfigure $filed -translation binary
+ fcopy $f $filed
+ close $f
+ seek $filed 0
+ }
+ set fileStats(hash) $hash
+ set fileStats(filename) $fileName
+ set ::vfs::template::version::filestats($filed) [array get fileStats]
+ return $filed
+}
+
+
+proc MountProcedure {args} {
+ upvar volume volume
+
+# take real and virtual directories from command line args.
+ set to [lindex $args end]
+ if [string equal $volume {}] {set to [::file normalize $to]}
+ set path [::file normalize [lindex $args end-1]]
+
+# make sure mount location exists:
+ ::file mkdir $path
+
+# add custom handling for new vfs args here.
+
+ set argsLength [llength $args]
+ for {set i 0} {$i < $argsLength} {incr i} {
+ switch -- [lindex $args $i] {
+ -keep {
+ set keep [lindex $args [incr i]]
+ if ![string is digit -strict $keep] {continue}
+ set ::vfs::template::version::keep($to) $keep
+ }
+ -project {
+ set project [lindex $args [incr i]]
+ set ::vfs::template::version::project($to) $project
+ }
+ -time {
+ set time [lindex $args [incr i]]
+ SetTime $time
+ set ::vfs::template::version::time($to) $time
+ }
+ }
+ }
+
+ if [catch {glob -directory $path -type {f hidden} .&dir*}] {
+ set root $to
+ file_mkdir $path
+ }
+
+
+# return two-item list consisting of real and virtual locations.
+ lappend pathto $path
+ lappend pathto $to
+ return $pathto
+}
+
+
+proc UnmountProcedure {path to} {
+# add custom unmount handling of new vfs elements here.
+ if [info exists ::vfs::template::version::keep($to)] {unset ::vfs::template::version::keep($to)}
+ if [info exists ::vfs::template::version::project($to)] {unset ::vfs::template::version::project($to)}
+ if [info exists ::vfs::template::version::time($to)] {unset ::vfs::template::version::time($to)}
+ return
+}
+
+# Can replace this proc with one that uses different hash function if preferred.
+proc Hash {channel} {
+ seek $channel 0
+ if [catch {package present md5 2}] {package forget md5 ; package require md5 2}
+ ::md5::md5 -hex -- [read $channel]
+}
+
+# figure out if time is a string, milliseconds or seconds count, return seconds cound
+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."}
+ set time "[string range $time 0 [expr [string length [clock seconds]] - 1]]000"
+}
+
+# decide which version is preferred considering time and project settings:
+proc VAcquireFile {path root relative {actualpath {}}} {
+ set fileName [VFileNameEncode [file join $path $relative]]
+ if [file isdirectory [file join $path $relative]] {
+ set fileName [file join $fileName .&dir[file tail $fileName]]
+ set relative [file join $relative .&dir[file tail $relative]]
+ }
+
+# grab all versions:
+ set versions [glob -path $fileName -nocomplain -types f "\;*"]
+ if [catch {::vfs::filesystem info $path}] {append versions " [glob -path $fileName -nocomplain -types "f hidden" "\;*"]"}
+
+ set versions [string trim $versions]
+ if {$versions == {}} {return [file join $path $relative]}
+
+ set checkProject 0
+ if [info exists ::vfs::template::version::project($root)] {
+ set projects [string map {; &s} [string map {& &a} $::vfs::template::version::project($root)]]
+ set checkProject 1
+ }
+
+# find versions that have current project tags to see if keep setting requires deleting any:
+ foreach ver $versions {
+ set ver $root/[file tail $ver]
+ lappend versionFiles $ver
+ if !$checkProject {continue}
+ foreach project $projects {
+ if {[lsearch [lrange [split $ver \;] 1 end] $project] > -1} {lappend projectFiles $ver}
+ }
+ }
+ unset versions
+
+# delete older versions if keep setting requires it:
+ if ![catch {if {[llength $projectFiles] <= $::vfs::template::version::keep($root)} {error}}] {
+ set keep $::vfs::template::version::keep($root)
+ set projectFiles [lsort -decreasing -dictionary $projectFiles]
+ set fileNumber [llength $projectFiles]
+ for {set i [incr fileNumber -1]} {$i >= 0} {incr i -1} {
+ if {[llength $projectFiles] <= $keep} {break}
+ set delFile [file join [file dirname [file join $path $relative]] [file tail [lindex $projectFiles $i]]]
+ if ![catch {file delete $delFile}] {set projectFiles [lreplace $projectFiles $i $i]}
+ }
+ }
+
+# find version that's best match with time and project settings:
+ set fileName [file tail [lindex [lsort -command VersionSort $versionFiles] 0]]
+
+# if file version has "deleted" tag, return with no version info, indicating file doesn't exist:
+ if !$checkProject {
+ if {[lindex [split $fileName \;] 2] == "deleted"} {return [file join $path $relative]}
+ }
+
+# if project attribute is set, and version has project tags, ensure version belongs to one of the set projects,
+# otherwise it will be invisible:
+ if $checkProject {
+ if {([lindex [split $fileName \;] 2] == "deleted") && ([lsearch $projects "deleted"] == -1)} {return [file join $path $relative]}
+ set projectMember 0
+ set tags [lrange [split $fileName \;] 1 end]
+ if {[lindex $tags 1] == "deleted"} {set tags [lreplace $tags 1 1]}
+ foreach project $projects {
+ if {[lsearch $tags $project] > -1} {set projectMember 1}
+ }
+ set projectLength [llength $tags]
+ if {($projectLength > 1) && !$projectMember} {return [file join $path $relative]}
+ }
+ if ![string first .&dir [file tail $relative]] {
+ set fileName [file join $path [file dirname $relative]]
+ return [file normalize $fileName]
+ }
+ return [file join [file dirname [file join $path $relative]] $fileName]
+}
+
+# create new version tag with millisecond-scale timestamp and curernt project tags:
+proc VCreateTag {root} {
+ set tag [clock seconds][string range [clock clicks -milliseconds] end-2 end]
+ if [info exists ::vfs::template::version::project($root)] {
+ set projects [string map {; &s} [string map {& &a} $::vfs::template::version::project($root)]]
+ set projectTag [join $projects \;]
+ set tag [join "$tag $projectTag" \;]
+ }
+ return $tag
+}
+
+# return info on all versions of a file:
+proc VersionsAll {path relative} {
+ set fileName [VFileNameEncode [file join $path $relative]]
+ if [file isdirectory [file join $path $relative]] {
+ set fileName [file join $fileName .&dir[file tail $fileName]]
+ set relative [file join $relative .&dir[file tail $relative]]
+ }
+ set versions [glob -path $fileName -nocomplain -types f "\;*"]
+ if [catch {::vfs::filesystem info $path}] {append versions " [glob -path $fileName -nocomplain -types "f hidden" "\;*"]"}
+
+ set versions [string trim $versions]
+
+ set newVersions {}
+ foreach ver $versions {
+ set ver [lrange [split $ver \;] 1 end]
+ set ver [file tail [VFileNameDecode $ver]]
+ set tag [lindex $ver 0]
+ set time [string range $tag 0 end-3]
+ set time [clock format $time -format "%Y%m%dT%H:%M:%S"]
+ lappend newVersions "$tag $time [list [lrange $ver 1 end]]"
+ }
+ return $newVersions
+}
+
+# specialized command for lsort, decide which of two versions is preferred given
+# project and time settings:
+proc VersionSort {element1 element2} {
+ set root [file dirname $element1]
+ set element1 [file tail $element1]
+ set element2 [file tail $element2]
+ if [string equal $element1 $element2] {return 0}
+ set sorted [lsort -dictionary -decreasing "$element1 $element2"]
+
+# decision 1: choose latest timestamp:
+ if {[lindex $sorted 0] == $element1} {set returnValue -1}
+ if {[lindex $sorted 0] == $element2} {set returnValue 1}
+
+ set time1 [lindex [split $element1 \;] 1]
+ set time2 [lindex [split $element2 \;] 1]
+ set time $time1
+ if {$time2 > $time1} {set time $time2}
+
+# decision 2: if time setting exists, choose latest timestamp less than time setting:
+ if [info exists ::vfs::template::version::time($root)] {
+ set returnValue -1
+ set time $::vfs::template::version::time($root)
+ if {!([string is digit -strict $time] && ([string length $time] == [string length $time1]))} {
+ set time [SetTime $::vfs::template::version::time($root)]
+ }
+
+ if {$time1 > $time} {set time1 [expr $time2 - 1]}
+ if {($time2 <= $time) && ($time2 > $time1)} {set returnValue 1}
+ }
+
+# decision 3: choose version with greatest number of project tag matches with project setting:
+ if [info exists ::vfs::template::version::project($root)] {
+ set projects [string map {; &s} [string map {& &a} $::vfs::template::version::project($root)]]
+ set project1 0
+ set project2 0
+ foreach project [lsort -unique $projects] {
+ set sumproject1 [lsearch [lrange [split $element1 \;] 1 end] $project]
+ set sumproject2 [lsearch [lrange [split $element2 \;] 1 end] $project]
+ incr sumproject1 ; incr sumproject2
+ if $sumproject1 {incr project1}
+ if $sumproject2 {incr project2}
+ }
+ if {$project1 > $project2} {set project1 1 ; set project2 0}
+ if {$project1 < $project2} {set project1 0 ; set project2 1}
+
+ # don't count "deleted" as a project tag for purpose of choosing default:
+ set tagEnd1 [lindex [split $element1 \;] 2]
+ if {$tagEnd1 == "deleted"} {set tagEnd1 [lindex [split $element1 \;] 3]}
+ set tagEnd2 [lindex [split $element2 \;] 2]
+ if {$tagEnd2 == "deleted"} {set tagEnd2 [lindex [split $element2 \;] 3]}
+
+ # set version with no project tags as default choice:
+ if {($tagEnd1 == {}) && !($tagEnd2 == {})} {set returnValue -1}
+ if {!($tagEnd1 == {}) && ($tagEnd2 == {})} {set returnValue 1}
+
+ # if a project tag match exists, replace default choice with it:
+ if {$project2 && !$project1 && ($time2 <= $time)} {set returnValue 1}
+ if {$project1 && !$project2 && ($time1 <= $time)} {set returnValue -1}
+ }
+ return $returnValue
+}
+
+# ampersand and semicolon are privileged chars in tagging,
+# encode and decode filenames containing them:
+proc VFileNameEncode {filename} {
+ set filename [file dirname $filename]/[string map {& &a} [file tail $filename]]
+ set filename [file dirname $filename]/[string map {; &s} [file tail $filename]]
+}
+
+proc VFileNameDecode {filename} {
+ set filename [file dirname $filename]/[lindex [split [file tail $filename] \;] 0]
+ set filename [file dirname $filename]/[string map {&s ;} [file tail $filename]]
+ set filename [file dirname $filename]/[string map {&a &} [file tail $filename]]
+}
+
+}
+# end namespace ::vfs::template::version
+
projects / tclvfs / commitdiff