#!/bin/sh
#\
exec tclsh "$0" ${1+"$@"}
# ReadKit, a viewer/extractor/converter for scripted documents which does
# not require TclKit or MetaKit. This file was generated by "rkgen.tcl".
#
# June 2002, Jean-Claude Wippler <jcw@equi4.com>
proc usage {} {
puts stdout {
ReadKit 1.0 is a pure Tcl script to view and extract the contents of
scripted documents (see also <http://www.equi4.com/scripdoc/>).
Run this script with any tclsh, wish, or tclkit release >= 8.0:
readkit -l sdfile lists the contents of the scripted doc
readkit -x sdfile extract full contents to "sdfile.vfs/"
readkit -z sdfile copy to a zip archive named "sdfile.zip"
Keep in mind that ZLIB decompression support is required to be able
to extract compressed files (the default), e.g. Trf or Zlib packages.
Note also that if you can't extract, you can still copy to zip format.
This utility will not overwrite existing files or directories.
}
exit 0
}
# 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] }
}
}
}
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 get_sub {names subs index} {
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]
return [mvec $v::node($h) $index] }
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_prop"} {
error "vnames? $view" }
return [lindex $view 1] }
proc vlen {view} {
# return the number of rows in this view
if {[lindex $view 0] != "get_view"} {
error "vlen? $view" }
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} {
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} {
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} {
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 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 {$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} {
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} {
# only handle the simplest case: exact matches
if {[llength $args] % 2 != 0 || [lsearch $args -*] >= 0} {
error "mk_select?" }
set keys {}
set value {}
foreach {k v} $args {
lappend keys $k
lappend values $v }
set r {}
mk_loop c $path {
set x [eval mk_get $c $keys]
if {$x == $values} {
lappend r [mk_cursor position c] } }
return $r }
# vim: ft=tcl
}
if {[info comm zipper::initialize] == ""} {
# ZIP file constructor
package provide zipper 0.11
namespace eval zipper {
namespace export initialize addentry finalize
namespace eval v {
variable fd
variable base
variable toc }
proc initialize {fd} {
set v::fd $fd
set v::base [tell $fd]
set v::toc {}
fconfigure $fd -translation binary -encoding binary }
proc emit {s} {
puts -nonewline $v::fd $s }
proc dostime {sec} {
set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt 1]
regsub -all { 0(\d)} $f { \1} f
foreach {Y M D h m s} $f break
set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}]
set time [expr {($h<<11) | ($m<<5) | ($s>>1)}]
return [list $date $time] }
proc addentry {name contents {date ""} {force 0}} {
if {$date == ""} {
set date [clock seconds] }
foreach {date time} [dostime $date] break
set flag 0
set type 0 ;# stored
set fsize [string length $contents]
set csize $fsize
set fnlen [string length $name]
if {$force > 0 && $force != [string length $contents]} {
set csize $fsize
set fsize $force
set type 8 ;# if we're passing in compressed data, it's deflated }
if {[catch { zlib crc32 $contents } crc]} {
set crc 0 } \
elseif {$type == 0} {
set cdata [zlib deflate $contents]
if {[string length $cdata] < [string length $contents]} {
set contents $cdata
set csize [string length $cdata]
set type 8 ;# deflate } }
lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} $flag $type $time $date $crc $csize $fsize $fnlen {0 0 0 0} 128 [tell $v::fd]]$name"
emit [binary format a2c4ssssiiiss PK {3 4 20 0} $flag $type $time $date $crc $csize $fsize $fnlen 0]
emit $name
emit $contents }
proc finalize {} {
set pos [tell $v::fd]
set ntoc [llength $v::toc]
foreach x $v::toc { emit $x }
set v::toc {}
set len [expr {[tell $v::fd] - $pos}]
incr pos -$v::base
emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $pos 0]
return $v::fd } }
if {[info exists pkgtest] && $pkgtest} {
puts "no test code" }
if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} {
# test code below runs when this is launched as the main script
catch { package require zlib }
zipper::initialize [open try.zip w]
set dirs [list .]
while {[llength $dirs] > 0} {
set d [lindex $dirs 0]
set dirs [lrange $dirs 1 end]
foreach f [lsort [glob -nocomplain [file join $d *]]] {
if {[file isfile $f]} {
regsub {^\./} $f {} f
set fd [open $f]
fconfigure $fd -translation binary -encoding binary
zipper::addentry $f [read $fd] [file mtime $f]
close $fd } \
elseif {[file isdir $f]} {
lappend dirs $f } } }
close [zipper::finalize]
puts "size = [file size try.zip]"
puts [exec unzip -v try.zip]
file delete try.zip }
# vim: ft=tcl
}
# set up the MetaKit compatibility definitions
foreach x {file view cursor get loop select} {
interp alias {} ::mk::$x {} ::mk_$x
}
# recursive contents lister
proc dirwalk {{verbose 0} {row 0} {path ""}} {
puts "\n$path/"
mk::loop c db.dirs!$row.files {
foreach {nm sz dt} [mk::get $c name size date] break
set t [clock format $dt -format {%Y/%m/%d %H:%M:%S}]
puts [format { %10d %s %s} $sz $t $nm]
}
mk::loop c db.dirs [expr {$row+1}] {
if {[mk::get $c parent] == $row} {
set n [mk::get $c name]
dirwalk $verbose [mk::cursor pos c] "$path/$n"
}
}
}
# recursive contents extractor
proc dirextract {{verbose 0} {row 0} {path ""}} {
if {$verbose} { puts " $path/" }
file mkdir $path
mk::loop c db.dirs!$row.files {
foreach {nm sz dt co} [mk::get $c name size date contents] break
if {$verbose} { puts " $path/$nm" }
if {$sz != [string length $co] &&
[catch { zlib decompress $co } co]} {
puts stderr "No zlib decompression support, consider using '-z'."
exit 1
}
set fd [open $path/$nm w]
fconfigure $fd -translation binary
puts -nonewline $fd $co
close $fd
# can only adjust time if Tcl supports it
catch { file mtime $path/$nm $dt }
}
mk::loop c db.dirs [expr {$row+1}] {
if {[mk::get $c parent] == $row} {
set n [mk::get $c name]
dirextract $verbose [mk::cursor pos c] "$path/$n"
}
}
}
# recursive zip conversion
proc dirtozip {{verbose 0} {row 0} {path ""}} {
mk::loop c db.dirs!$row.files {
foreach {nm sz dt co} [mk::get $c name size date contents] break
if {$verbose} { puts " $path/$nm" }
set e 0
if {$sz != [string length $co]} {
set e $sz
set co [string range $co 2 end-4]
}
zipper::addentry [string range $path/$nm 1 end] $co $dt $e
}
mk::loop c db.dirs [expr {$row+1}] {
if {[mk::get $c parent] == $row} {
set n [mk::get $c name]
dirtozip $verbose [mk::cursor pos c] "$path/$n"
}
}
}
# try to end up with a usable zlib command
proc need-zlib {} {
if {[info commands zlib] == ""} {
catch { package require zlib }
}
if {[catch { zlib compress haha }]} {
catch { package require Trf }
if {![catch { ::zip -mode compress haha }]} {
proc zlib {mode data} {
return [::zip -mode $mode $data]
}
} elseif {![catch { ::vfs::zip -mode compress haha }]} {
proc zlib {mode data} {
return [::vfs::zip -mode $mode $data]
}
}
}
}
if {[llength $argv] != 2} usage
lassign $argv mode file
if {![file readable $file]} {
puts stderr "Cannot read input file '$file'"
exit 1
}
mk::file open db $file
switch -- $mode {
-l {
dirwalk
puts ""
}
-x {
need-zlib
set base [file root [file tail $file]].vfs
if {[file exists $base]} {
puts stderr "Cannot create output directory, '$base' already exists"
exit 1
}
dirextract 1 0 $base
}
-z {
set base [file root [file tail $file]].zip
if {[file exists $base]} {
puts stderr "Cannot create output file, '$base' already exists"
exit 1
}
zipper::initialize [open $base w]
dirtozip
close [zipper::finalize]
}
default { usage }
}
# vim: ft=tcl