[SEH] An LZW-compressing virtual filesystem.

Usage: Mount <existing directory> <virtual directory>

All file contents are stored in an LZW-compressed format. Uncompressed file size is tracked and reported via file stat command, so compression is invisible to user.

LZW compression procedures adapted from JR's contributions at [LZW]

Daisy-chain this with [mkvfs], and you've got something akin to a pure-Tcl tar.gz archive construct, with the advantage that individual files can be accessed, edited and replaced without having to decompress and re-compress the whole archive.  Not to mention perfectly cross-platform compatible.

 package require vfs 1

 namespace eval ::vfs::template::compress {}

 proc ::vfs::template::compress::Mount {args} {
	set pathto [eval MountProcedure $args]
	set path [lindex $pathto 0]
	set to [lindex $pathto 1]
	::vfs::filesystem mount $to [list ::vfs::template::compress::handler $path]
	::vfs::RegisterMount $to [list ::vfs::template::compress::Unmount]
	return $to
 }

 proc ::vfs::template::compress::Unmount {to} {
	set path [lindex [::vfs::filesystem info $to] end]
	UnmountProcedure $path $to
	::vfs::filesystem unmount $to
 }

 proc ::vfs::template::compress::handler {path cmd root relative actualpath args} {
	switch -- $cmd {
		access {
			set mode [lindex $args 0]
			set error [catch {Access $path $root $relative $actualpath $mode}]
			if $error {vfs::filesystem posixerror $::vfs::posix(EACCES) ; return -code error $::vfs::posix(EACCES)}
		}
		createdirectory {
			CreateDirectory $path $root $relative $actualpath
		}
		deletefile {
			DeleteFile $path $root $relative $actualpath
		}
		fileattributes {
			set index [lindex $args 0]
			set value [lindex $args 1]
			array set attributes [FileAttributes $path $root $relative $actualpath]
			if {$index == {}} {
				return [lsort [array names attributes]]
			}
			set attribute [lindex [lsort [array names attributes]] $index]
			if {$value == {}} {
				return $attributes($attribute)
			}
			FileAttributesSet $path $root $relative $actualpath $attribute $value
		}
		matchindirectory {
			set pattern [lindex $args 0]
			set types [lindex $args 1]
			return [MatchInDirectory $path $root $relative $actualpath $pattern $types]
		} open {
			set mode [lindex $args 0]
			if {$mode == {}} {set mode r}
			set permissions [lindex $args 1]
			set channelID [Open $path $root $relative $actualpath $mode $permissions]
			switch -glob -- $mode {
				"" -
				"r*" -
				"w*" {
					seek $channelID 0
				}
				"a*" {
	    				seek $channelID 0 end
				}
				default {
					::vfs::filesystem posixerror $::vfs::posix(EINVAL)
					return -code error $::vfs::posix(EINVAL)
				}
			}
			set result $channelID
			lappend result [list ::vfs::template::compress::Close $channelID $path $root $relative $actualpath $mode]
			return $result
		}
		removedirectory {
			set recursive [lindex $args 0]
			if !$recursive {
				if {[MatchInDirectory $path $root $relative $actualpath * 0] != {}} {
					::vfs::filesystem posixerror $::vfs::posix(EEXIST)
					return -code error $::vfs::posix(EEXIST)
				}
			}
			RemoveDirectory $path $root $relative $actualpath
		}
		stat {
			return [Stat $path $root $relative $actualpath]
		}
		utime {
			set atime [lindex $args 0]
			set mtime [lindex $args 1]
			Utime $path $root $relative $actualpath $atime $mtime
		}
	}
 }

 namespace eval ::vfs::template::compress {

 proc MountProcedure {args} {
	set path [lindex $args 0]
	set path [file normalize $path]
	set to [lindex $args 1]
	set to [file normalize $to
	if {![catch {vfs::filesystem info $to}]} {
		# unmount old mount
		Unmount $to
	}


	file mkdir $path

	lappend pathto $path
	lappend pathto $to
	return $pathto
 }

 proc UnmountProcedure {path to} {
	return
 }

 proc Access {path root relative actualpath mode} {
	set modeString [::vfs::accessMode $mode]
	if {$modeString == "F"} {set modeString RWX}
	set modeString [split $modeString {}]
	set fileName [AcquireFile $path $relative]
	if [file readable $fileName] {lappend fileString R}
	if [file writable $fileName] {lappend fileString W}
	if [file executable $fileName] {lappend fileString X}
	foreach mS $modeString {
		set errorMessage "not [string map {R readable W writable X executable} $mS]"
		if {[lsearch $fileString $mS] == -1} {error $errorMessage}
	}
 }

 proc CreateDirectory {path root relative actualpath} {
	file mkdir [file join $path $relative]
 }

 proc DeleteFile {path root relative actualpath} {
	set fileName [AcquireFile $path $relative]
	file delete $fileName
 }

 proc FileAttributes {path root relative actualpath} {
	set fileName [AcquireFile $path $relative]
	file attributes $fileName
 }

 proc FileAttributesSet {path root relative actualpath attribute value} {
	set fileName [AcquireFile $path $relative]
	file attributes $fileName $attribute $value
 }

 proc MatchInDirectory {path root relative actualpath pattern types} {
	if [::vfs::matchDirectories $types] {lappend typeString d}
	if [::vfs::matchFiles $types] {lappend typeString f}

	set globList [glob -directory [file join $path $relative] -nocomplain -types $typeString *]
	set pathLength [expr [string length $path] - 1]
	set newGlobList {}
	foreach gL $globList {
		set gL [join [lrange [split $gL .] 0 end-1] .]
		set gL [string replace $gL 0 $pathLength $root]
		if [string match $pattern [file tail $gL]] {lappend newGlobList $gL}
	}
	return [lsort -unique $newGlobList]
 }

 proc Open {path root relative actualpath mode permissions} {
	set fileName [AcquireFile $path $relative]
	if ![file exists $fileName] {
		set channelID [open $fileName $mode]
		catch {file attributes $fileName -permissions $permissions}
		return $channelID
	}
	set f [open $fileName r]
	fconfigure $f -translation binary
	set cdataEncode [read $f]
	close $f

	set data [Decompress $cdataEncode]
	unset cdataEncode
	set filed [vfs::memchan]
	fconfigure $filed -translation binary
	puts -nonewline $filed $data
	unset data
	fconfigure $filed -translation auto
	seek $filed 0
	return $filed
 }

 proc Close {channelID path root relative actualpath mode} {
 # Do not close the channel in the close callback!
 # It will crash Tcl!  Honest!
 # The core will close the channel after you've taken what info you need from it.

 #	close $channelID
	if {$mode == "r"} {return}
	fconfigure $channelID -translation binary
	seek $channelID 0
	set data [read $channelID]
	set fileSize [string length $data]
	set cdataEncode [Compress $data]
	unset data
	set fileName [AcquireFile $path $relative]
	set newFileName [file join $path $relative].$fileSize
	file rename $fileName $newFileName
	set f [open $newFileName w]
	fconfigure $f -translation binary
	puts -nonewline $f $cdataEncode
	close $f
	return
 }

 proc RemoveDirectory {path root relative actualpath} {
	file delete -force [file join $path $relative]
 }

 proc Stat {path root relative actualpath} {
	set fileName [AcquireFile $path $relative]
	set fileSize [lindex [split $fileName .] end]
	file stat [file join $path $relative] fs
	set fs(size) $fileSize
	return [array get fs]
 }

 proc Utime {path root relative actualpath atime mtime} {
	set fileName [AcquireFile $path $relative]
	file atime $fileName $atime
	file mtime $fileName $mtime
 }

 proc AcquireFile {path relative} {
	set fileNames [glob -nocomplain -path [file join $path $relative] .*]
	foreach fn $fileNames {
		if [regexp "[file join $path $relative]\.\[0-9\]+" $fn] {return $fn}
 	}
	return [file join $path $relative].0
 }

 proc Compress {data} {
      if {$data == {}} {return {}}
      set cpre {}
      for {set x 0} {$x < 256} {incr x} {set dict([binary format c $x]) $x}
      set pos 0
      set rval {}
	set string_length_data [string length $data]
      while {$pos < $string_length_data} {
        set ch [string index $data $pos]
        incr pos
        set ci [array names dict -exact $cpre$ch]


        if {$ci != {}} {
          # string in dictionary
          append cpre $ch
        } else {
          set dict($cpre$ch) [array size dict]
          lappend rval $dict($cpre)
          set cpre $ch
        }
      }
      lappend rval $dict($cpre)
	foreach rv $rval {
		if {$rv == 38} {
			append rvalEncode "&0;"
		} elseif {$rv == 59} {
			append rvalEncode "&1;"
		} elseif {$rv > 255} {
			set rv [expr $rv - 254]
			append rvalEncode "&$rv;"
		} else {
			append rvalEncode [binary format c $rv]
		}
	}
	set rvalEncode [string map {;& { }} $rvalEncode]
      return $rvalEncode
 }

 proc Decompress {cdataEncode} {
	if {$cdataEncode == {}} {return {}}
	set string_length_cdataEncode [string length $cdataEncode]
	set pos 0
	while {$pos < $string_length_cdataEncode} {
		set strIndex [string index $cdataEncode $pos]
		if {$strIndex == "&"} {
			while {[set strIndex [string index $cdataEncode [incr pos]]] != "\;"} {
				if {$strIndex == { }} {
					if {$cDatum == 0} {
						set cDatum 38
					} elseif {$cDatum == 1} {
						set cDatum 59
					} else {
						set cDatum [expr $cDatum + 254]
					}
					lappend cdata $cDatum
					unset cDatum
				}
				append cDatum $strIndex
			}
			if {$cDatum == 0} {
				set cDatum 38
			} elseif {$cDatum == 1} {
				set cDatum 59
			} else {
				set cDatum [expr $cDatum + 254]
			}
			lappend cdata $cDatum
			unset cDatum
		} else {
			binary scan $strIndex c strIndex
			lappend cdata $strIndex
		}
		incr pos
	}

      set cpre {}
      set dict {}
      for {set x 0} {$x < 256} {incr x} {lappend dict [binary format c $x]}
      set pos 0
      set rval {}
	set llength_cdata [llength $cdata]
      while {$pos < $llength_cdata} {
        set co [lindex $cdata $pos]
        incr pos
        if {$co >= [llength $dict]} {
          lappend dict $cpre[string index $cpre 0]
          set cpre [lindex $dict $co]
        } else {
          append cpre [string index [lindex $dict $co] 0]
          # this only won't apply for the very first character
          if {[string length $cpre] > 1} {
            lappend dict $cpre
          }
          set cpre [lindex $dict $co]
        }
        append rval [lindex $dict $co]
      }
      return $rval
 }

 }
 # end namespace eval vfs::template::compress


[[[Category VFS]]]