Artifact 122176da293daccca87927a43fa6a0e4640dc94e:

• File kitsh/buildsrc/kitsh-0.0/mk4tcl.tcl — part of check-in [096098536d] at 2010-09-26 04:42:20 on branch trunk — Updated to implement "vfs::mkcl" using Readkit

  Updated local Readkit implementation to not attempt to replace Mk4tcl (user: rkeene, size: 34093) [annotate] [blame] [check-ins using]

#! /usr/bin/env tclsh
# ReadKit, a viewer/extractor/converter for starkits which does not
# require TclKit or MetaKit.  This file was generated by "rkgen.tcl".
#
# June 2002, Jean-Claude Wippler <jcw@equi4.com>

# this is needed so often that I just drop copies of it all over the place
if {![info exists auto_index(lassign)] && [info commands lassign] == ""} {
  proc lassign {l args} {
    foreach v $l a $args { uplevel 1 [list set $a $v] }
  }
}

catch {
	load {} zlib
}
catch {
	package require zlib
}

if {[info comm mmap] == ""} {
    # mmap and mvec primitives in pure Tcl (a C version is present in critlib)

    namespace export mmap mvec

    namespace eval v {
	array set mmap_data {}
	array set mvec_shifts {
    - -1    0 -1
    1  0    2  1    4  2    8   3
    16 4   16r 4
    32 5   32r 5   32f 5   32fr 5
    64 6   64r 6   64f 6   64fr 6 }
    }

    proc mmap {fd args} {
	upvar #0 v::mmap_data($fd) data
	# special case if fd is the name of a variable (qualified or global)
	if {[uplevel #0 [list info exists $fd]]} {
	    upvar #0 $fd var
	    set data $var
	}
	# cache a full copy of the file to simulate memory mapping
	if {![info exists data]} {
	    set pos [tell $fd]
	    seek $fd 0 end
	    set end [tell $fd]
	    seek $fd 0
	    set trans [fconfigure $fd -translation]
	    fconfigure $fd -translation binary
	    set data [read $fd $end]
	    fconfigure $fd -translation $trans
	    seek $fd $pos
	}
	set total [string length $data]
	if {[llength $args] == 0} {
	    return $total
	}
	foreach {off len} $args break
	if {$len < 0} {
	    set len $total
	}
	if {$len < 0 || $len > $total - $off} {
	    set len [expr {$total - $off}]
	}
	binary scan $data @${off}a$len s
	return $s
    }

    proc mvec {v args} {
	foreach {mode data off len} $v break
	if {[info exists v::mvec_shifts($mode)]} {
	    # use _mvec_get to access elements
	    set shift $v::mvec_shifts($mode)
	    if {[llength $v] < 4} {
		set len $off
	    }
	    set get [list _mvec_get $shift $v *]
	} else {
	    # virtual mode, set to evaluate script
	    set shift ""
	    set len [lindex $v end]
	    set get $v
	}
	# try to derive vector length from data length if not specified
	if {$len == "" || $len < 0} {
	    set len 0
	    if {$shift >= 0} {
		if {[llength $v] < 4} {
		    set n [string length $data]
		} else {
		    set n [mmap $data]
		}
		set len [expr {($n << 3) >> $shift}]
	    }
	}
	set nargs [llength $args]
	# with just a varname as arg, return info about this vector
	if {$nargs == 0} {
	    if {$shift == ""} {
		return [list $len {} $v]
	    }
	    return [list $len $mode $shift]
	}
	foreach {pos count pred cond} $args break
	# with an index as second arg, do a single access and return element
	if {$nargs == 1} {
	    return [uplevel 1 [lreplace $get end end $pos]]
	}
	if {$count < 0} {
	    set count $len
	}
	if {$count > $len - $pos && $shift != -1} {
	    set count [expr {$len - $pos}]
	}
	if {$nargs == 4} {
	    upvar $pred x
	}
	set r {}
	incr count $pos
	# loop through specified range to build result vector
	# with four args, used that as predicate function to filter
	# with five args, use fourth as loop var and apply fifth as condition
	for {set x $pos} {$x < $count} {incr x} {
	    set y [uplevel 1 [lreplace $get end end $x]]
	    switch $nargs {
		3 {
			if {![uplevel 1 [list $pred $v $x $y]]} continue
		    }
		4 {
			if {![uplevel 1 [list expr $cond]]} continue
		    }
	    }
	    lappend r $y
	}
	return $r
    }

    proc _mvec_get {shift desc index} {
	foreach {mode data off len} $desc break
	switch -- $mode {
	    - {
		    return $index
		}
	    0 {
		    return $data
		}
	}
	if {[llength $desc] < 4} {
	    set off [expr {($index << $shift) >> 3}]
	} else {
	    # don't load more than 8 bytes from the proper offset
	    incr off [expr {($index << $shift) >> 3}]
	    set data [mmap $data $off 8]
	    set off 0
	}
	switch -- $mode {
	    1 {
		    binary scan $data @${off}c value
		    return [expr {($value>>($index&7)) &1}]
		}
	    2 {
		    binary scan $data @${off}c value
		    return [expr {($value>>(($index&3) <<1)) &3}]
		}
	    4 {
		    binary scan $data @${off}c value
		    return [expr {($value>>(($index&1) <<2)) &15}]
		}
	    8 {
		    set w 1
		    set f c
		}
	    16 {
		    set w 2
		    set f s
		}
	    16r {
		    set w 2
		    set f S
		}
	    32 {
		    set w 4
		    set f i
		}
	    32r {
		    set w 4
		    set f I
		}
	    32fr -
	    32f {
		    set w 4
		    set f f
		}
	    64 -
	    64r {
		    set w 8
		    set f i2
		}
	    64fr -
	    64f {
		    set w 8
		    set f d
		}
	}

	binary scan $data @$off$f value
	return $value
    }

    # vim: ft=tcl

}

if {[info comm dbopen] == ""} {
    # Decoder for MetaKit datafiles in Tcl

    # requires mmap/mvec primitives:
    #source [file join [info dirname [info script]] mvprim.tcl]

    namespace export dbopen dbclose dbtree access vnames vlen

    namespace eval v {
	variable widths {
    {8 16  1 32  2  4}
    {4  8  1 16  2  0}
    {2  4  8  1  0 16}
    {2  4  0  8  1  0}
    {1  2  4  0  8  0}
    {1  2  4  0  0  8}
    {1  2  0  4  0  0} }
    }

    proc fetch {file} {
	if {$file == ""} {
	    error "temp storages not supported"
	}
	set v::data [open $file]
	set v::seqn 0
    }

    proc byte_seg {off len} {
	incr off $v::zero
	return [mmap $v::data $off $len]
    }

    proc int_seg {off cnt} {
	set vec [list 32r [byte_seg $off [expr {4*$cnt}]]]
	return [mvec $vec 0 $cnt]
    }

    proc get_s {len} {
	set s [byte_seg $v::curr $len]
	incr v::curr $len
	return $s
    }

    proc get_v {} {
	set v 0
	while 1 {
	    set char [mvec $v::byte $v::curr]
	    incr v::curr
	    set v [expr {$v*128+($char&0xff)}]
	    if {$char < 0} {
		return [incr v -128]
	    }
	}
    }

    proc get_p {rows vs vo} {
	upvar $vs size $vo off
	set off 0
	if {$rows == 0} {
	    set size 0
	} else {
	    set size [get_v]
	    if {$size > 0} {
		set off [get_v]
	    }
	}
    }

    proc header {{end ""}} {
	set v::zero 0
	if {$end == ""} {
	    set end [mmap $v::data]
	}
	set v::byte [list 8 $v::data $v::zero $end]
	lassign [int_seg [expr {$end-16}] 4] t1 t2 t3 t4
	set v::zero [expr {$end-$t2-16}]
	incr end -$v::zero
	set v::byte [list 8 $v::data $v::zero $end]
	lassign [int_seg 0 2] h1 h2
	lassign [int_seg [expr {$h2-8}] 2] e1 e2
	set v::info(mkend) $h2
	set v::info(mktoc) $e2
	set v::info(mklen) [expr {$e1 & 0xffffff}]
	set v::curr $e2
    }

    proc layout {fmt} {
	regsub -all { } $fmt "" fmt
	regsub -all {(\w+)\[} $fmt "{\\1 {" fmt
	regsub -all {\]} $fmt "}}" fmt
	regsub -all {,} $fmt " " fmt
	return $fmt
    }

    proc descparse {desc} {
	set names {}
	set types {}
	foreach x $desc {
	    if {[llength $x] == 1} {
		lassign [split $x :] name type
		if {$type == ""} {
		    set type S
		}
	    } else {
		lassign $x name type
	    }
	    lappend names $name
	    lappend types $type
	}
	return [list $names $types]
    }

    proc numvec {rows type} {
	get_p $rows size off
	if {$size == 0} {
	    return {0 0}
	}
	set w [expr {int(($size<<3) /$rows)}]
	if {$rows <= 7 && 0 < $size && $size <= 6} {
	    set w [lindex [lindex $v::widths [expr {$rows-1}]] [expr {$size-1}]]
	}
	if {$w == 0} {
	    error "numvec?"
	}
	switch $type\
	      F {
		    set w 32f
		}\
	      D {
		    set w 64f
		}
	incr off $v::zero
	return [list $w $v::data $off $rows]
    }

    proc lazy_str {self rows type pos sizes msize moff index} {
	set soff {}
	for {set i 0} {$i < $rows} {incr i} {
	    set n [mvec $sizes $i]
	    lappend soff $pos
	    incr pos $n
	}
	if {$msize > 0} {
	    set slen [mvec $sizes 0 $rows]
	    set v::curr $moff
	    set limit [expr {$moff+$msize}]
	    for {set row 0} {$v::curr < $limit} {incr row} {
		incr row [get_v]
		get_p 1 ms mo
		set soff [lreplace $soff $row $row $mo]
		set slen [lreplace $slen $row $row $ms]
	    }
	    set sizes [list lindex $slen $rows]
	}
	if {$type == "S"} {
	    set adj -1
	} else {
	    set adj 0
	}
	set v::node($self) [list get_str $soff $sizes $adj $rows]
	return [mvec $v::node($self) $index]
    }

    proc get_str {soff sizes adj index} {
	set n [mvec $sizes $index]
	return [byte_seg [lindex $soff $index] [incr n $adj]]
    }

    proc lazy_sub {self desc size off rows index} {
	set v::curr $off
	lassign [descparse $desc] names types
	set subs {}
	for {set i 0} {$i < $rows} {incr i} {
	    if {[get_v] != 0} {
		error "lazy_sub?"
	    }
	    lappend subs [prepare $types]
	}
	set v::node($self) [list get_sub $names $subs $rows]
	return [mvec $v::node($self) $index]
    }

#proc backtrace {{level_adj 0}} {
#                        set ret [list]          
#
#                        set level [expr 0 - $level_adj]
#                        for {set i [expr [info level] - $level_adj]} {$i > 1} {incr i -1} {
#                                incr level -1
#                                set ret [linsert $ret 0 [lindex [info level $level] 0]]
#                        }
#                        set ret [linsert $ret 0 GLOBAL]
#        
#                        return $ret
#}

    proc get_sub {names subs index} {
#puts stderr "DEBUG: get_sub: [list $names $subs $index]"
#puts "backtrace: [backtrace]"
	lassign [lindex $subs $index] rows handlers
	return [list get_view $names $rows $handlers $rows]
    }

    proc prepare {types} {
	set r [get_v]
	set handlers {}
	foreach x $types {
	    set n [incr v::seqn]
	    lappend handlers $n
	    switch $x {
		I -
		L -
		F -
		D {
			set v::node($n) [numvec $r $x]
		    }
		B -
		S {
			get_p $r size off
			set sizes {0 0}
			if {$size > 0} {
			    set sizes [numvec $r I]
			}
			get_p $r msize moff
			set v::node($n) [list lazy_str $n $r $x $off $sizes\
			  $msize $moff $r]
		    }
		default {
			get_p $r size off
			set v::node($n) [list lazy_sub $n $x $size $off $r $r]
		    }
	    }
	}
	return [list $r $handlers]
    }

    proc get_view {names rows handlers index} {
	return [list get_prop $names $rows $handlers $index [llength $names]]
    }

    proc get_prop {names rows handlers index ident} {
	set col [lsearch -exact $names $ident]
	if {$col < 0} {
	    error "unknown property: $ident"
	}
	set h [lindex $handlers $col]
	set ret [mvec $v::node($h) $index]

	return $ret
    }

    proc dbopen {db file} {
	# open datafile, stores datafile descriptors and starts building tree
	if {$db == ""} {
	    set r {}
	    foreach {k v} [array get v::dbs] {
		lappend r $k [lindex $v 0]
	    }
	    return $r
	}
	fetch $file
	header
	if {[get_v] != 0} {
	    error "dbopen?"
	}
	set desc [layout [get_s [get_v]]]
	lassign [descparse $desc] names types
	set root [get_sub $names [list [prepare $types]] 0]
	set v::dbs($db) [list $file $v::data $desc [mvec $root 0]]
	return $db
    }

    proc dbclose {db} {
	# close datafile, get rid of stored info
	unset v::dbs($db)
	set v::data "" ;# it may be big 
    }

    proc dbtree {db} {
	# datafile selection, first step in access navigation loop
	return [lindex $v::dbs($db) 3]
    }

    proc access {spec} {
	# this is the main access navigation loop
	set s [split $spec ".!"]
	set x [list dbtree [array size v::dbs]]
	foreach y $s {
	    set x [mvec $x $y]
	}
	return $x
    }

    proc vnames {view} {
	# return a list of property names
	if {[lindex $view 0] != "get_view"} {
	    error "vnames?"
	}
	return [lindex $view 1]
    }

    proc vlen {view} {
	# return the number of rows in this view
	if {[lindex $view 0] != "get_view"} {
	    error "vlen?"
	}
	return [lindex $view 2]
    }

    # vim: ft=tcl

}

if {[info comm mk_file] == ""} {
    # Compatibility layer for MetaKit

    # requires dbopen/dbclose/dbtree/access/vnames/vlen/mvec primitives
    #source [file join [info dirname [info script]] decode.tcl]

    namespace export mk_*

    proc mk_file {cmd args} {
#set indent [string repeat "    " [info level]]
#puts stderr "${indent}DEBUG: readkit::file $cmd $args"
	lassign $args db file
	switch $cmd {
	    open {
		    return [dbopen $db $file]
		}
	    close {
		    dbclose $db
		}
	    views {
		    return [vnames [dbtree $db]]
		}
	    commit {

		}
	    default {
		    error "mk_file $cmd?"
		}
	}
    }

    proc mk_view {cmd path args} {
#set indent [string repeat "    " [info level]]
#puts stderr "${indent}DEBUG: readkit::view $cmd $path $args"
	lassign $args a1
	switch $cmd {
	    info {
		    return [vnames [access $path]]
		}
	    layout {
		    set layout "NOTYET"
		    if {[llength $args] > 0 && $layout != $a1} {
			#error "view restructuring not supported"
		    }
		    return $layout
		}
	    size {
		    set len [vlen [access $path]]
		    if {[llength $args] > 0 && $len != $a1} {
			error "view resizing not supported"
		    }
		    return [vlen [access $path]]
		}
	    default {
		    error "mk_view $cmd?"
		}
	}
    }

    proc mk_cursor {cmd cursor args} {
#set indent [string repeat "    " [info level]]
#puts stderr "${indent}DEBUG: readkit::cursor $cmd $cursor $args"
	upvar $cursor v
	switch $cmd {
	    create {
		    NOTYET
		}
	    incr {
		    NOTYET
		}
	    pos -
	    position {
		    if {$args != ""} {
			regsub {!-?\d+$} $v {} v
			append v !$args
			return $args
		    }
		    if {![regexp {\d+$} $v n]} {
			set n -1
		    }
		    return $n
		}
	    default {
		    error "mk_cursor $cmd?"
		}
	}
    }

    proc mk_get {path args} {
#set indent [string repeat "    " [info level]]
#puts stderr "${indent}DEBUG: readkit::get $path $args"
	set rowref [access $path]
	set sized 0
	if {[lindex $args 0] == "-size"} {
	    set sized 1
	    set args [lrange $args 1 end]
	}
	set ids 0
	if {[llength $args] == 0} {
	    set args [vnames $rowref]
	    set ids 1
	}
	set r {}
	foreach x $args {
	    if {$ids} {
		lappend r $x
	    }
	    set v [mvec $rowref $x]
if {[string range $v 0 8] == "get_view "} {
# XXX: ?!?!?: TODO: FIX
set v 1
}
	    catch {
		set v [zlib decompress $v]
	    }
	    if {$sized} {
		lappend r [string length $v]
	    } else {
		lappend r $v
	    }
	}
	if {[llength $args] == 1} {
	    set r [lindex $r 0]
	}

	return $r
    }

    proc mk_loop {cursor path args} {
#set indent [string repeat "    " [info level]]
#puts stderr "${indent}DEBUG: readkit::loop $cursor $path ..."
	upvar $cursor v
	if {[llength $args] == 0} {
	    set args [list $path]
	    set path $v
	    regsub {!-?\d+$} $path {} path
	}
	lassign $args a1 a2 a3 a4
	set rowref [access $path]
	set first 0
	set limit [vlen $rowref]
	set step 1
	switch [llength $args] {
	    1 {
		    set body $a1
		}
	    2 {
		    set first $a1
		    set body $a2
		}
	    3 {
		    set first $a1
		    set limit $a2
		    set body $a3
		}
	    4 {
		    set first $a1
		    set limit $a2
		    set step $a3
		    set body $a4
		}
	    default {
		    error "mk_loop arg count?"
		}
	}
	set code 0
	for {set i $first} {$i < $limit} {incr i $step} {
	    set v $path!$i
	    set code [catch [list uplevel 1 $body] err]
	    switch $code {
		1 -
		2 {
			return -code $code $err
		    }
		3 {
			break
		    }
	    }
	}
    }

    proc mk_select {path args} {
#set indent [string repeat "    " [info level]]
#puts stderr "${indent}DEBUG: readkit::select $path $args"
	# only handle the simplest case: exact matches
	if {[lindex $args 0] == "-count"} {
		set maxitems [lindex $args 1]
		set args [lrange $args 2 end]
	}

	set currmatchmode "caseinsensitive"

	set keys {}
	set value {}
	set matchmodes {}
	for {set idx 0} {$idx < [llength $args]} {incr idx 2} {
		switch -glob -- [lindex $args $idx] {
			"-glob" {
				set currmatchmode "glob"
				incr idx -1
				continue
			}
			"-*" {
				error "Unhandled option: [lindex $args $idx]"
			}
		}

		set k [lindex $args $idx]
		set v [lindex $args [expr {$idx+1}]]

		lappend keys $k
		lappend values $v
		lappend matchmodes $currmatchmode
	}
	set r {}
	mk_loop c $path {
		set x [eval mk_get $c $keys]
		set matchCnt 0
		for {set idx 0} {$idx < [llength $x]} {incr idx} {
			set val [lindex $values $idx]
			set chkval [lindex $x $idx]
			set matchmode [lindex $matchmodes $idx]

			switch -- $matchmode {
				"caseinsensitive" {
					if {$val == $chkval} {
						incr matchCnt
					}
				}
				"glob" {
					if {[string match $val $chkval]} {
						incr matchCnt
					}
				}
			}

		}
		if {$matchCnt == [llength $keys]} {
			lappend r [mk_cursor position c]
		}
	}

	if {[info exists maxitems]} {
		set r [lrange $r 0 [expr $maxitems - 1]]
	}

	return $r
    }

    proc mk__rechan {path prop cmd chan args} {
#set indent [string repeat "    " [info level]]
#puts stderr "${indent}DEBUG: readkit::_rechan $path $prop $cmd $chan $args"

        set key [list $path $prop]
        if {![info exists ::mk__cache($key)]} {
          set ::mk__cache($key) [readkit::get $path $prop]
        }
        if {![info exists ::mk__offset($key)]} {
          set ::mk__offset($key) 0
        }
        set data $::mk__cache($key)
        set offset $::mk__offset($key)

        switch -- $cmd {
            "read" {
                set count [lindex $args 0]
                set retval [string range $data $offset [expr {$offset + $count - 1}]]

                set readbytes [string length $retval]

                incr offset $readbytes
            }
            "close" {
                unset -nocomplain ::mk__cache($key)
                unset -nocomplain ::mk__offset($key)
                return
            }
            default {
#puts stderr "${indent}DEBUG: readkit::_rechan: Called for cmd $cmd"
                return -code error "Not implemented: cmd = $cmd"
            }
        }

        set ::mk__offset($key) $offset

	return $retval
    }

    proc mk_channel {path prop {mode "r"}} {
#set indent [string repeat "    " [info level]]
#puts stderr "${indent}DEBUG: readkit::channel $path $prop $mode"
	set fd [rechan [list mk__rechan $path $prop] 2]

	return $fd
    }
    # vim: ft=tcl

}

# set up the MetaKit compatibility definitions
foreach x {file view cursor get loop select channel} {
    interp alias {} ::readkit::$x {} ::mk_$x
}



# mk4vfs.tcl -- Mk4tcl Virtual File System driver
# Copyright (C) 1997-2003 Sensus Consulting Ltd. All Rights Reserved.
# Matt Newman <matt@sensus.org> and Jean-Claude Wippler <jcw@equi4.com>
#
# $Id: mk4vfs.tcl,v 1.41 2008/04/15 21:11:53 andreas_kupries Exp $
#
# 05apr02 jcw	1.3	fixed append mode & close,
#			privatized memchan_handler
#			added zip, crc back in
# 28apr02 jcw	1.4	reorged memchan and pkg dependencies
# 22jun02 jcw	1.5	fixed recursive dir deletion
# 16oct02 jcw	1.6	fixed periodic commit once a change is made
# 20jan03 jcw	1.7	streamed zlib decompress mode, reduces memory usage
# 01feb03 jcw	1.8	fix mounting a symlink, cleanup mount/unmount procs
# 04feb03 jcw	1.8	whoops, restored vfs::mkcl::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)

# Removed provision of the backward compatible name. Moved to separate
# file/package.
catch {
	load {} vfs
}
package require vfs

# things that can no longer really be left out (but this is the wrong spot!)
# be as non-invasive as possible, using these definitions as last resort

namespace eval vfs::mkcl {
    proc Mount {mkfile local args} {
	if {$mkfile != ""} {
	  # dereference a symlink, otherwise mounting on it fails (why?)
	  catch {
	    set mkfile [file join [file dirname $mkfile] \
	    			  [file readlink $mkfile]]
	  }
	  set mkfile [file normalize $mkfile]
	}
	set db [eval [list ::mkcl_vfs::_mount $mkfile] $args]
	::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
	::mkcl_vfs::_umount $db
    }

    proc attributes {db} { return [list "state" "commit"] }
    
    # Can use this to control commit/nocommit or whatever.
    # I'm not sure yet of what functionality jcw needs.
    proc commit {db args} {
	switch -- [llength $args] {
	    0 {
		if {$::mkcl_vfs::v::mode($db) == "readonly"} {
		    return 0
		} else {
		    # To Do: read the commit state
		    return 1
		}
	    }
	    1 {
		set val [lindex $args 0]
		if {$val != 0 && $val != 1} {
		    return -code error \
		      "invalid commit value $val, must be 0,1"
		}
		# To Do: set the commit state.
	    }
	    default {
		return -code error "Wrong num args"
	    }
	}
    }
    
    proc state {db args} {
	switch -- [llength $args] {
	    0 {
		return $::mkcl_vfs::v::mode($db)
	    }
	    1 {
		set val [lindex $args 0]
		if {[lsearch -exact [::vfs::states] $val] == -1} {
		    return -code error \
		      "invalid state $val, must be one of: [vfs::states]"
		}
		set ::mkcl_vfs::v::mode($db) $val
		::mkcl_vfs::setupCommits $db
	    }
	    default {
		return -code error "Wrong num args"
	    }
	}
    }
    
    proc handler {db cmd root relative actualpath args} {
	#puts stderr "handler: $db - $cmd - $root - $relative - $actualpath - $args"
	if {$cmd == "matchindirectory"} {
	    eval [list $cmd $db $relative $actualpath] $args
	} elseif {$cmd == "fileattributes"} {
	    eval [list $cmd $db $root $relative] $args
	} else {
	    eval [list $cmd $db $relative] $args
	}
    }

    proc utime {db path actime modtime} {
	::mkcl_vfs::stat $db $path sb
	
	if { $sb(type) == "file" } {
	    readkit::set $sb(ino) date $modtime
	}
    }

    proc matchindirectory {db path actualpath pattern type} {
	set newres [list]
	if {![string length $pattern]} {
	    # check single file
	    if {[catch {access $db $path 0}]} {
		return {}
	    }
	    set res [list $actualpath]
	    set actualpath ""
	} else {
	    set res [::mkcl_vfs::getdir $db $path $pattern]
	}
	foreach p [::vfs::matchCorrectTypes $type $res $actualpath] {
	    lappend newres [file join $actualpath $p]
	}
	return $newres
    }

    proc stat {db name} {
	::mkcl_vfs::stat $db $name sb

	set sb(ino) 0
	array get sb
    }

    proc access {db name mode} {
	if {$mode & 2} {
	    if {$::mkcl_vfs::v::mode($db) == "readonly"} {
		vfs::filesystem posixerror $::vfs::posix(EROFS)
	    }
	}
	# We can probably do this more efficiently, can't we?
	::mkcl_vfs::stat $db $name sb
    }

    proc open {db file mode permissions} {
	# return a list of two elements:
	# 1. first element is the Tcl channel name which has been opened
	# 2. second element (optional) is a command to evaluate when
	#  the channel is closed.
	switch -glob -- $mode {
	    {}  -
	    r {
		::mkcl_vfs::stat $db $file sb

		if { $sb(csize) != $sb(size) } {
		    if {$::mkcl_vfs::zstreamed} {
		      set fd [readkit::channel $sb(ino) contents r]
		      fconfigure $fd -translation binary
		      set fd [vfs::zstream decompress $fd $sb(csize) $sb(size)]
		    } else {
		      set fd [vfs::memchan]
		      fconfigure $fd -translation binary
		      set s [readkit::get $sb(ino) contents]
		      puts -nonewline $fd [vfs::zip -mode decompress $s]

		      fconfigure $fd -translation auto
		      seek $fd 0
		    }
		} elseif { $::mkcl_vfs::direct } {
		    set fd [vfs::memchan]
		    fconfigure $fd -translation binary
		    puts -nonewline $fd [readkit::get $sb(ino) contents]

		    fconfigure $fd -translation auto
		    seek $fd 0
		} else {
		    set fd [readkit::channel $sb(ino) contents r]
		}
		return [list $fd]
	    }
	    a {
		if {$::mkcl_vfs::v::mode($db) == "readonly"} {
		    vfs::filesystem posixerror $::vfs::posix(EROFS)
		}
		if { [catch {::mkcl_vfs::stat $db $file sb }] } {
		    # Create file
		    ::mkcl_vfs::stat $db [file dirname $file] sb
		    set tail [file tail $file]
		    set fview $sb(ino).files
		    if {[info exists mkcl_vfs::v::fcache($fview)]} {
			lappend mkcl_vfs::v::fcache($fview) $tail
		    }
		    set now [clock seconds]
		    set sb(ino) [readkit::row append $fview \
			    name $tail size 0 date $now ]

		    if { [string match *z* $mode] || $mkcl_vfs::compress } {
			set sb(csize) -1  ;# HACK - force compression
		    } else {
			set sb(csize) 0
		    }
		}

		set fd [vfs::memchan]
		fconfigure $fd -translation binary
		set s [readkit::get $sb(ino) contents]

		if { $sb(csize) != $sb(size) && $sb(csize) > 0 } {
		    append mode z
		    puts -nonewline $fd [vfs::zip -mode decompress $s]
		} else {
		    if { $mkcl_vfs::compress } { append mode z }
		    puts -nonewline $fd $s
		    #set fd [readkit::channel $sb(ino) contents a]
		}
		fconfigure $fd -translation auto
		seek $fd 0 end
		return [list $fd [list mkcl_vfs::do_close $db $fd $mode $sb(ino)]]
	    }
	    w*  {
		if {$::mkcl_vfs::v::mode($db) == "readonly"} {
		    vfs::filesystem posixerror $::vfs::posix(EROFS)
		}
		if { [catch {::mkcl_vfs::stat $db $file sb }] } {
		    # Create file
		    ::mkcl_vfs::stat $db [file dirname $file] sb
		    set tail [file tail $file]
		    set fview $sb(ino).files
		    if {[info exists mkcl_vfs::v::fcache($fview)]} {
			lappend mkcl_vfs::v::fcache($fview) $tail
		    }
		    set now [clock seconds]
		    set sb(ino) [readkit::row append $fview \
			    name $tail size 0 date $now ]
		}

		if { [string match *z* $mode] || $mkcl_vfs::compress } {
		    append mode z
		    set fd [vfs::memchan]
		} else {
		    set fd [readkit::channel $sb(ino) contents w]
		}
		return [list $fd [list mkcl_vfs::do_close $db $fd $mode $sb(ino)]]
	    }
	    default   {
		error "illegal access mode \"$mode\""
	    }
	}
    }

    proc createdirectory {db name} {
	mkcl_vfs::mkdir $db $name
    }

    proc removedirectory {db name recursive} {
	mkcl_vfs::delete $db $name $recursive
    }

    proc deletefile {db name} {
	mkcl_vfs::delete $db $name
    }

    proc fileattributes {db root relative args} {
	switch -- [llength $args] {
	    0 {
		# list strings
		return [::vfs::listAttributes]
	    }
	    1 {
		# get value
		set index [lindex $args 0]
		return [::vfs::attributesGet $root $relative $index]

	    }
	    2 {
		# set value
		if {$::mkcl_vfs::v::mode($db) == "readonly"} {
		    vfs::filesystem posixerror $::vfs::posix(EROFS)
		}
		set index [lindex $args 0]
		set val [lindex $args 1]
		return [::vfs::attributesSet $root $relative $index $val]
	    }
	}
    }
}

namespace eval mkcl_vfs {
    variable compress 1     ;# HACK - needs to be part of "Super-Block"
    variable flush    5000  ;# Auto-Commit frequency
    variable direct   0	    ;# read through a memchan, or from Mk4tcl if zero
    variable zstreamed 0    ;# decompress on the fly (needs zlib 1.1)

    namespace eval v {
	variable seq      0
	variable mode	    ;# array key is db, value is mode 
	             	     # (readwrite/translucent/readonly)
	variable timer	    ;# array key is db, set to afterid, periodicCommit

	array set cache {}
	array set fcache {}

	array set mode {exe translucent}
    }

    proc init {db} {
	readkit::view layout $db.dirs \
		{name:S parent:I {files {name:S size:I date:I contents:M}}}

	if { [readkit::view size $db.dirs] == 0 } {
	    readkit::row append $db.dirs name <root> parent -1
	}
    }

    proc _mount {{file ""} args} {
	set db mk4vfs[incr v::seq]

	if {$file == ""} {
	    readkit::file open $db
	    init $db
	    set v::mode($db) "translucent"
	} else {
	    eval [list readkit::file open $db $file] $args
	    
	    init $db
	    
	    set mode 0
	    foreach arg $args {
		switch -- $arg {
		    -readonly   { set mode 1 }
		    -nocommit   { set mode 2 }
		}
	    }
	    if {$mode == 0} {
		periodicCommit $db
	    }
	    set v::mode($db) [lindex {translucent readwrite readwrite} $mode]
	}
	return $db
    }

    proc periodicCommit {db} {
	variable flush
	set v::timer($db) [after $flush [list ::mkcl_vfs::periodicCommit $db]]
	readkit::file commit $db
	return ;# 2005-01-20 avoid returning a value
    }

    proc _umount {db args} {
	catch {after cancel $v::timer($db)}
	array unset v::mode $db
	array unset v::timer $db
	array unset v::cache $db,*
	array unset v::fcache $db.*
	readkit::file close $db
    }

    proc stat {db path {arr ""}} {
	set sp [::file split $path]
	set tail [lindex $sp end]

	set parent 0
	set view $db.dirs
	set type directory

	foreach ele [lrange $sp 0 end-1] {
	    if {[info exists v::cache($db,$parent,$ele)]} {
		set parent $v::cache($db,$parent,$ele)
	    } else {
		set row [readkit::select $view -count 1 parent $parent name $ele]
		if { $row == "" } {
		    vfs::filesystem posixerror $::vfs::posix(ENOENT)
		}
		set v::cache($db,$parent,$ele) $row
		set parent $row
	    }
	}
	
	# Now check if final comp is a directory or a file
	# CACHING is required - it can deliver a x15 speed-up!
	
	if { [string equal $tail "."] || [string equal $tail ":"] \
	  || [string equal $tail ""] } {
	    set row $parent

	} elseif { [info exists v::cache($db,$parent,$tail)] } {
	    set row $v::cache($db,$parent,$tail)
	} else {
	    # File?
	    set fview $view!$parent.files
	    # create a name cache of files in this directory
	    if {![info exists v::fcache($fview)]} {
		# cache only a limited number of directories
		if {[array size v::fcache] >= 10} {
		    array unset v::fcache *
		}
		set v::fcache($fview) {}
		readkit::loop c $fview {
		    lappend v::fcache($fview) [readkit::get $c name]
		}
	    }
	    set row [lsearch -exact $v::fcache($fview) $tail]
	    #set row [readkit::select $fview -count 1 name $tail]
	    #if {$row == ""} { set row -1 }
	    if { $row != -1 } {
		set type file
		set view $view!$parent.files
	    } else {
		# Directory?
		set row [readkit::select $view -count 1 parent $parent name $tail]
		if { $row != "" } {
		    set v::cache($db,$parent,$tail) $row
		} else { 
		    vfs::filesystem posixerror $::vfs::posix(ENOENT)
		}
	    }
	}
 
        if {![string length $arr]} {
            # The caller doesn't need more detailed information.
            return 1
        }
 
	set cur $view!$row

	upvar 1 $arr sb

	set sb(type)    $type
	set sb(view)    $view
	set sb(ino)     $cur

	if { [string equal $type "directory"] } {
	    set sb(atime) 0
	    set sb(ctime) 0
	    set sb(gid)   0
	    set sb(mode)  0777
	    set sb(mtime) 0
	    set sb(nlink) [expr { [readkit::get $cur files] + 1 }]
	    set sb(size)  0
	    set sb(csize) 0
	    set sb(uid)   0
	} else {
	    set mtime   [readkit::get $cur date]
	    set sb(atime) $mtime
	    set sb(ctime) $mtime
	    set sb(gid)   0
	    set sb(mode)  0777
	    set sb(mtime) $mtime
	    set sb(nlink) 1
	    set sb(size)  [readkit::get $cur size]
	    set sb(csize) [readkit::get $cur -size contents]
	    set sb(uid)   0
	}
    }

    proc do_close {db fd mode cur} {
	if {![regexp {[aw]} $mode]} {
	    error "mkcl_vfs::do_close called with bad mode: $mode"
	}

	readkit::set $cur size -1 date [clock seconds]
	flush $fd
	if { [string match *z* $mode] } {
	    fconfigure $fd -translation binary
	    seek $fd 0
	    set data [read $fd]
	    set cdata [vfs::zip -mode compress $data]
	    set len [string length $data]
	    set clen [string length $cdata]
	    if { $clen < $len } {
		readkit::set $cur size $len contents $cdata
	    } else {
		readkit::set $cur size $len contents $data
	    }
	} else {
	    readkit::set $cur size [readkit::get $cur -size contents]
	}
	# 16oct02 new logic to start a periodic commit timer if not yet running
	setupCommits $db
	return ""
    }

    proc setupCommits {db} {
	if {$v::mode($db) eq "readwrite" && ![info exists v::timer($db)]} {
	    periodicCommit $db
	    readkit::file autocommit $db
	}
    }

    proc mkdir {db path} {
	if {$v::mode($db) == "readonly"} {
	    vfs::filesystem posixerror $::vfs::posix(EROFS)
	}
	set sp [::file split $path]
	set parent 0
	set view $db.dirs

	set npath {}
	# This actually does more work than is needed. Tcl's
	# vfs only requires us to create the last piece, and
	# Tcl already knows it is not a file.
	foreach ele $sp {
	    set npath [file join $npath $ele]

	    if {![catch {stat $db $npath sb}] } {
		if { $sb(type) != "directory" } {
		    vfs::filesystem posixerror $::vfs::posix(EROFS)
		}
		set parent [readkit::cursor position sb(ino)]
		continue
	    }
	    #set parent [readkit::cursor position sb(ino)]
	    set cur [readkit::row append $view name $ele parent $parent]
	    set parent [readkit::cursor position cur]
	}
	setupCommits $db
	return ""
    }

    proc getdir {db path {pat *}} {
	if {[catch { stat $db $path sb }] || $sb(type) != "directory" } {
	    return
	}

	# Match directories
	set parent [readkit::cursor position sb(ino)] 
	foreach row [readkit::select $sb(view) parent $parent -glob name $pat] {
	    set hits([readkit::get $sb(view)!$row name]) 1
	}
	# Match files
	set view $sb(view)!$parent.files
	foreach row [readkit::select $view -glob name $pat] {
	    set hits([readkit::get $view!$row name]) 1
	}
	return [lsort [array names hits]]
    }

    proc mtime {db path time} {
	if {$v::mode($db) == "readonly"} {
	    vfs::filesystem posixerror $::vfs::posix(EROFS)
	}
	stat $db $path sb
	if { $sb(type) == "file" } {
	    readkit::set $sb(ino) date $time
	}
	return $time
    }

    proc delete {db path {recursive 0}} {
	#puts stderr "mk4delete db $db path $path recursive $recursive"
	if {$v::mode($db) == "readonly"} {
	    vfs::filesystem posixerror $::vfs::posix(EROFS)
	}
	stat $db $path sb
	if {$sb(type) == "file" } {
	    readkit::row delete $sb(ino)
	    if {[regexp {(.*)!(\d+)} $sb(ino) - v r] \
		    && [info exists v::fcache($v)]} {
		set v::fcache($v) [lreplace $v::fcache($v) $r $r]
	    }
	} else {
	    # just mark dirs as deleted
	    set contents [getdir $db $path *]
	    if {$recursive} {
		# We have to delete these manually, else
		# they (or their cache) may conflict with
		# something later
		foreach f $contents {
		    delete $db [file join $path $f] $recursive
		}
	    } else {
		if {[llength $contents]} {
		    vfs::filesystem posixerror $::vfs::posix(ENOTEMPTY)
		}
	    }
	    array unset v::cache \
		    "$db,[readkit::get $sb(ino) parent],[file tail $path]"
	    
	    # flag with -99, because parent -1 is not reserved for the root dir
	    # deleted entries never get re-used, should be cleaned up one day
	    readkit::set $sb(ino) parent -99 name ""
	    # get rid of file entries to release the space in the datafile
	    readkit::view size $sb(ino).files 0
	}
	setupCommits $db
	return ""
    }
}

package provide readkit 0.8
package provide vfs::mkcl 2.4.0.1