From e2e682f6600bc6adeeb1384f010be82e0554e918 Mon Sep 17 00:00:00 2001
From: Jean-Claude Wippler <jcw@equi4.com>
Date: Wed, 19 Oct 2005 10:58:00 +0000
Subject: [PATCH] added support for tclkitlite
---
ChangeLog | 6 ++
library/mk4vfs.tcl | 14 ++--
library/mkclvfs.tcl | 150 +++++++++++++++++++++++++++++++++++++++++++
library/pkgIndex.tcl | 5 +-
pkgIndex.tcl.in | 5 +-
5 files changed, 172 insertions(+), 8 deletions(-)
create mode 100644 library/mkclvfs.tcl
diff --git a/ChangeLog b/ChangeLog
index 4375621..f6a3dc6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2005-10-19 Jean-Claude Wippler <jcw@equi4.com>
+
+ * library/mk4vfs.tcl: added fallback to new vfs::mkcl
+ * library/mkclvfs.tcl: new MK Compatible Lite driver
+ * pkgIndex.tcl.in, library/pkgIndex.tcl: adjusted
+
2005-08-31 Vince Darley <vincentdarley@sourceforge.net>
* generic/vfs.c: despite lack of documentation on this point,
diff --git a/library/mk4vfs.tcl b/library/mk4vfs.tcl
index 3c12f65..5cb3e8b 100644
--- a/library/mk4vfs.tcl
+++ b/library/mk4vfs.tcl
@@ -14,10 +14,10 @@
# 01feb03 jcw 1.8 fix mounting a symlink, cleanup mount/unmount procs
# 04feb03 jcw 1.8 whoops, restored vfs::mk4::Unmount logic
# 17mar03 jcw 1.9 start with mode translucent or readwrite
+# 18oct05 jcw 1.10 add fallback to MK Compatible Lite driver (vfs::mkcl)
-package provide mk4vfs 1.9
-package provide vfs::mk4 1.9
-package require Mk4tcl
+package provide mk4vfs 1.10
+package provide vfs::mk4 1.10
package require vfs
# need this so init failure in interactive mode does not mess up errorInfo
@@ -38,6 +38,12 @@ if {![info exists auto_index(lassign)] && [info commands lassign] == ""} {
namespace eval vfs::mk4 {
proc Mount {mkfile local args} {
+ # 2005-10-19 switch to MK Compatible Lite driver if there is no Mk4tcl
+ if {[catch { package require Mk4tcl }]} {
+ package require vfs::mkcl
+ return [eval [linsert $args 0 vfs::mkcl::Mount $mkfile $local]]
+ }
+
if {$mkfile != ""} {
# dereference a symlink, otherwise mounting on it fails (why?)
catch {
@@ -120,7 +126,7 @@ namespace eval vfs::mk4 {
::mk4vfs::stat $db $path sb
if { $sb(type) == "file" } {
- ::mk::set $sb(ino) date $modtime
+ mk::set $sb(ino) date $modtime
}
}
diff --git a/library/mkclvfs.tcl b/library/mkclvfs.tcl
new file mode 100644
index 0000000..65966ed
--- /dev/null
+++ b/library/mkclvfs.tcl
@@ -0,0 +1,150 @@
+# mkclvfs.tcl -- Metakit Compatible Lite Virtual File System driver
+# Rewritten from mk4vfs.tcl, orig by by Matt Newman and Jean-Claude Wippler
+# $Id$
+
+package provide vfs::mkcl 1.0
+package require vfs
+package require vlerq
+
+namespace eval vfs::mkcl {
+ namespace import ::vlerq::*
+
+ namespace eval v {
+ variable seq 0 ;# used to generate a unique db handle
+ variable rootv ;# maps handle to root view (well, actually "dirs")
+ variable dname ;# maps handle to cached list of directory names
+ variable prows ;# maps handle to cached list of parent row numbers
+ }
+
+# public
+ proc Mount {mkfile local args} {
+ set db mkclvfs[incr v::seq]
+ set v::rootv($db) [view [vlerq::vopen $mkfile] get 0 dirs]
+ set v::dname($db) [view $v::rootv($db) getcol 0]
+ set v::prows($db) [view $v::rootv($db) getcol 1]
+ ::vfs::filesystem mount $local [list ::vfs::mkcl::handler $db]
+ ::vfs::RegisterMount $local [list ::vfs::mkcl::Unmount $db]
+ return $db
+ }
+ proc Unmount {db local} {
+ ::vfs::filesystem unmount $local
+ unset v::rootv($db) v::dname($db) v::prows($db)
+ }
+# private
+ proc handler {db cmd root path actual args} {
+ #puts [list MKCL $db <$cmd> r: $root p: $path a: $actual $args]
+ switch $cmd {
+ matchindirectory { eval [linsert $args 0 $cmd $db $path $actual] }
+ fileattributes { eval [linsert $args 0 $cmd $db $root $path] }
+ default { eval [linsert $args 0 $cmd $db $path] }
+ }
+ }
+ proc fail {code} {
+ ::vfs::filesystem posixerror $::vfs::posix($code)
+ }
+ proc lookUp {db path} {
+ set dirs $v::rootv($db)
+ set parent 0
+ set elems [file split $path]
+ set remain [llength $elems]
+ foreach e $elems {
+ set r ""
+ foreach r [lsearch -exact -int -all $v::prows($db) $parent] {
+ if {$e eq [lindex $v::dname($db) $r]} {
+ set parent $r
+ incr remain -1
+ break
+ }
+ }
+ if {$parent != $r} {
+ if {$remain == 1} {
+ set files [view $dirs get $parent 2]
+ set i [lsearch -exact [view $files getcol 0] $e]
+ if {$i >= 0} {
+ # evaluating this 4-item result returns the info about one file
+ return [list view $files get $i]
+ }
+ }
+ fail ENOENT
+ }
+ }
+ # evaluating this 5-item result returns the files subview
+ return [list view $dirs get $parent 2]
+ }
+ proc isDir {tag} {
+ return [expr {[llength $tag] == 5}]
+ }
+# methods
+ proc matchindirectory {db path actual pattern type} {
+ set o {}
+ if {$type == 0} { set type 20 }
+ set tag [lookUp $db $path]
+ if {$pattern ne ""} {
+ set c {}
+ if {[isDir $tag]} {
+ # collect file names
+ if {$type & 16} {
+ set c [eval [linsert $tag end | getcol 0]]
+ }
+ # collect directory names
+ if {$type & 4} {
+ foreach r [lsearch -exact -int -all $v::prows($db) [lindex $tag 3]] {
+ lappend c [lindex $v::dname($db) $r]
+ }
+ }
+ }
+ foreach x $c {
+ if {[string match $pattern $x]} {
+ lappend o [file join $actual $x]
+ }
+ }
+ } elseif {$type & ([isDir $tag]?4:16)} {
+ set o [list $actual]
+ }
+ return $o
+ }
+ proc fileattributes {db root path args} {
+ switch -- [llength $args] {
+ 0 { return [::vfs::listAttributes] }
+ 1 { set index [lindex $args 0]
+ return [::vfs::attributesGet $root $path $index] }
+ 2 { fail EROFS }
+ }
+ }
+ proc open {db file mode permissions} {
+ if {$mode ne "" && $mode ne "r"} { fail EROFS }
+ set tag [lookUp $db $file]
+ if {[isDir $tag]} { fail ENOENT }
+ foreach {name size date contents} [eval $tag] break
+ if {[string length $contents] != $size} {
+ set contents [vfs::zip -mode decompress $contents]
+ }
+ set fd [vfs::memchan]
+ fconfigure $fd -translation binary
+ puts -nonewline $fd $contents
+ fconfigure $fd -translation auto
+ seek $fd 0
+ return [list $fd]
+ }
+ proc access {db path mode} {
+ if {$mode & 2} { fail EROFS }
+ lookUp $db $path
+ }
+ proc stat {db path} {
+ set tag [lookUp $db $path]
+ set l 1
+ if {[isDir $tag]} {
+ set t directory
+ set s 0
+ set d 0
+ set c ""
+ incr l [eval [linsert $tag end | size]]
+ incr l [llength [lsearch -exact -int -all $v::prows($db) [lindex $tag 3]]]
+ } else {
+ set t file
+ foreach {n s d c} [eval $tag] break
+ }
+ return [list type $t size $s atime $d ctime $d mtime $d nlink $l \
+ csize [string length $c] gid 0 uid 0 ino 0 mode 0777]
+ }
+}
diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl
index 25aab85..031bbb8 100644
--- a/library/pkgIndex.tcl
+++ b/library/pkgIndex.tcl
@@ -49,13 +49,14 @@ package ifneeded starkit 1.3.1 [list source [file join $dir starkit.tcl]]
package ifneeded vfslib 1.3.1 [list source [file join $dir vfslib.tcl]]
# Old
-package ifneeded mk4vfs 1.9 [list source [file join $dir mk4vfs.tcl]]
+package ifneeded mk4vfs 1.10 [list source [file join $dir mk4vfs.tcl]]
package ifneeded zipvfs 1.0 [list source [file join $dir zipvfs.tcl]]
# New
package ifneeded vfs::ftp 1.0 [list source [file join $dir ftpvfs.tcl]]
package ifneeded vfs::http 0.5 [list source [file join $dir httpvfs.tcl]]
-package ifneeded vfs::mk4 1.9 [list source [file join $dir mk4vfs.tcl]]
+package ifneeded vfs::mk4 1.10 [list source [file join $dir mk4vfs.tcl]]
+package ifneeded vfs::mkcl 1.0 [list source [file join $dir mkclvfs.tcl]]
package ifneeded vfs::ns 0.5 [list source [file join $dir tclprocvfs.tcl]]
package ifneeded vfs::tar 0.9 [list source [file join $dir tarvfs.tcl]]
package ifneeded vfs::test 1.0 [list source [file join $dir testvfs.tcl]]
diff --git a/pkgIndex.tcl.in b/pkgIndex.tcl.in
index 3c1794e..88dc31b 100644
--- a/pkgIndex.tcl.in
+++ b/pkgIndex.tcl.in
@@ -33,13 +33,14 @@ package ifneeded starkit 1.3.1 [list source [file join $dir starkit.tcl]]
package ifneeded vfslib 1.3.1 [list source [file join $dir vfslib.tcl]]
# Old
-package ifneeded mk4vfs 1.9 [list source [file join $dir mk4vfs.tcl]]
+package ifneeded mk4vfs 1.10 [list source [file join $dir mk4vfs.tcl]]
package ifneeded zipvfs 1.0 [list source [file join $dir zipvfs.tcl]]
# New
package ifneeded vfs::ftp 1.0 [list source [file join $dir ftpvfs.tcl]]
package ifneeded vfs::http 0.5 [list source [file join $dir httpvfs.tcl]]
-package ifneeded vfs::mk4 1.9 [list source [file join $dir mk4vfs.tcl]]
+package ifneeded vfs::mk4 1.10 [list source [file join $dir mk4vfs.tcl]]
+package ifneeded vfs::mkcl 1.0 [list source [file join $dir mkclvfs.tcl]]
package ifneeded vfs::ns 0.5 [list source [file join $dir tclprocvfs.tcl]]
package ifneeded vfs::tar 0.9 [list source [file join $dir tarvfs.tcl]]
package ifneeded vfs::test 1.0 [list source [file join $dir testvfs.tcl]]
--
2.23.0