From: Jean-Claude Wippler <jcw@equi4.com>
Date: Wed, 19 Oct 2005 10:58:00 +0000 (+0000)
Subject: added support for tclkitlite
X-Git-Tag: vfs-1-4~70
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=e2e682f6600bc6adeeb1384f010be82e0554e918;p=tclvfs

added support for tclkitlite
---

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]]