# -*- tcl -*- Tcl Module

########## Repository Information Block ###

# @@ Meta Begin
# Package vfs::mkcl 1.4
# Meta as::origin  http://sf.net/projects/tclvfs
# Meta category    Virtual filesystems
# Meta description Tclvfs allows Virtual Filesystems to be built using Tcl
# Meta description scripts only. It is also a repository of such
# Meta description Tcl-implemented filesystems (metakit, zip, ftp, tar,
# Meta description http, webdav, namespace, url)
# Meta license     BSD
# Meta platform    tcl
# Meta require     {Tcl 8.4}
# Meta require     vfs
# Meta subject     zip ftp tar http webdav vfs filesystem metakit namespace
# Meta subject     url
# Meta summary     Extra virtual filesystems for Tcl.
# @@ Meta End


##########

########## Requirements Enforcement Code ###

package require Tcl 8.4
package require vfs

##########

########## Package Declaration Code ###

package provide vfs::mkcl 1.4

##########

# mkclvfs.tcl -- Metakit Compatible Lite Virtual File System driver
# Rewritten from mk4vfs.tcl, orig by by Matt Newman and Jean-Claude Wippler 

# 1.0	initial release
# 1.1	view size renamed to count
# 1.2	replace view calls by vget (simpler and faster)
# 1.3	modified to use the vlerq extension i.s.o. thrive
# 1.4 minor cleanup

package provide vfs::mkcl 1.4
package require vfs
package require vlerq

namespace eval vfs::mkcl {
  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 $mkfile mapf | get 0 dirs]
    set v::dname($db) [vget $v::rootv($db) * name]
    set v::prows($db) [vget $v::rootv($db) * parent]
    ::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 [vget $dirs $parent files]
      	  if 1 {
       	    set i [lsearch -exact [vget $files * name] $e]
        	  if {$i >= 0} {
        	    # evaluating this 3-item result returns the info about one file
        	    return [list vget $files $i]
        	  }
        	} else {
            view $files loop {
              if {$(name) eq $e} {
                # evaluating this 3-item result returns the info about one file
                return [list vget $files $(#)]
              }
            }
          }
      	}
      	fail ENOENT
      }
    }
    # evaluating this 4-item result returns the files subview
    return [list vget $dirs $parent files]
  }
  proc isDir {tag} {
    return [expr {[llength $tag] == 4}]
  }
# 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 * 0]]
      	}
      	# collect directory names
      	if {$type & 4} {
      	  foreach r [lsearch -exact -int -all $v::prows($db) [lindex $tag 2]] {
      	    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 -1 #]]
      incr l [llength [lsearch -exact -int -all $v::prows($db) [lindex $tag 2]]]
    } 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]
  }
}