#!/bin/sh
#\
exec tclsh "$0" ${1+"$@"}

# 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>

proc usage {} {
  puts stdout {
    ReadKit 1.0 is a pure Tcl script to view and extract the contents of 
    starkits (see also <http://www.equi4.com/starkit/>).

    Run this script with any tclsh, wish, or tclkit release >= 8.0:

    	readkit -l starkit	lists the contents of the starkit
	readkit -x starkit	extract full contents to "starkit.vfs/"
	readkit -z starkit	copy to a zip archive named "starkit.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_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} {
  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 {[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