#! /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] == ""} {
set auto_index(lassign) {
proc lassign {l args} {
foreach v $l a $args { uplevel 1 [list set $a $v] }
}
}
}
catch {
load {} zlib
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: mk::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: mk::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: mk::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: mk::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: mk::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: mk::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: mk::_rechan $path $prop $cmd $chan $args"
set key [list $path $prop]
if {![info exists ::mk__cache($key)]} {
set ::mk__cache($key) [mk::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: mk::_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: mk::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 {} ::mk::$x {} ::mk_$x
}
package provide Mk4tcl 2.4.0.1