#! /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
}
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 1 ;# 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