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

# Wikit listing/extraction tool
#
# This code does not require TclKit or Mk4tcl to run
#
# 2001-10-03 jcw	initial version
# 2001-10-17 jcw	order of magnitude faster
# 2002-06-21 jcw	adjusted to also work with new refs view

set auto_index(lassign) {
  proc lassign {l args} {foreach v $l a $args {uplevel 1 [list set $a $v]}}
}

#source mkintcl.tcl
# MetaKit-in-Tcl - Oct 2001, by Jean-Claude Wippler

namespace eval mkintcl {
  variable data
  variable zero
  variable info
  variable curr
  variable seqn
  variable node

  proc fetch {file} {
    variable data
    variable seqn 0
    set fd [open $file]
    fconfigure $fd -translation binary -encoding binary
    set data [read $fd]
    close $fd
  }

  proc byte_seg {off len} {
    variable data
    variable zero
    incr off $zero
    # avoid string indexing to prevent unicode conversions
    #return [string range $data $off [expr {$off+$len-1}]]
    binary scan $data @${off}a$len s
    return $s
  }

  proc int_seg {off cnt} {
    binary scan [byte_seg $off [expr {4*$cnt}]] I$cnt vec
    return $vec
  }

  proc get_s {len} {
    variable data
    variable curr
    set s [byte_seg $curr $len]
    incr curr $len
    return $s
  }

  proc get_b {} {
    binary scan [get_s 1] c char
    return [expr {$char & 0xff}]
  }

  proc Xget_v {} {
    set v 0
    while 1 {
      set b [get_b]
      set v [expr {$v*128+$b}]
      if {$b > 127} { return [incr v -128] }
    }
  }

    # optimized version
  proc get_v {} {
    variable data
    variable zero
    variable curr
    set v 0
    while 1 {
      binary scan $data @[expr {$curr+$zero}]c char
      incr curr
      set v [expr {$v*128+($char&0xff)}]
      if {$char < 0} { return [incr v -128] }
    }
  }

  proc get_p {rows} {
    if {$rows == 0} {
      set size 0
      set off 0
    } else {
      set size [get_v]
      if {$size > 0} {
	set off [get_v]
      } else {
	set off 0
      }
    }
    return [list $size $off]
  }

  proc header {{end ""}} {
    variable data
    variable info
    variable curr
    variable zero 0
    if {$end == ""} { set end [string length $data] }
    lassign [int_seg [expr {$end-16}] 4] t1 t2 t3 t4
    #set tlen [expr {$t1 & 0xffffff}]
    set zero [expr {$end-$t2-16}]
    lassign [int_seg 0 2] h1 h2
    lassign [int_seg [expr {$h2-8}] 2] e1 e2
    set info(mkend) $h2
    set info(mktoc) $e2
    set info(mklen) [expr {$e1 & 0xffffff}]
    set 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 get_i0 {off index} {
    return 0
  }

  proc get_i1 {off index} {
    incr off [expr {$index>>3}]
    binary scan [byte_seg $off 1] c value
    return [expr {($value>>($index&7))&1}]
  }

  proc get_i2 {off index} {
    incr off [expr {$index>>2}]
    binary scan [byte_seg $off 1] c value
    return [expr {($value>>(($index&3)<<1))&3}]
  }

  proc get_i4 {off index} {
    incr off [expr {$index>>1}]
    binary scan [byte_seg $off 1] c value
    return [expr {($value>>(($index&1)<<2))&15}]
  }

  proc get_num {off width fmt index} {
    binary scan [byte_seg [expr {$off+$width*$index}] $width] $fmt value
    return $value
  }

  proc get_str {offs lens index} {
    variable node
    return [byte_seg [lindex $node($offs) $index] [lindex $node($lens) $index]]
  }

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

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

  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 deducewidth {rows size} {
    variable widths
    set w 0
    if {$rows > 0} {
      set w [expr {int(($size<<3)/$rows)}]
      if {$rows <= 7 && 0 < $size && $size <= 6} {
        set w [lindex [lindex $widths [expr {$rows-1}]] [expr {$size-1}]]
	if {$w == 0} { error "bad width" }
      }
    }
    return $w
  }

  proc makenode {value} {
    variable seqn
    variable node
    set node([incr seqn]) $value
    return $seqn
  }

  proc numvec {rows type size off} {
    set w [deducewidth $rows $size]
    if {$w == 0} { set type I }
    switch $type {
      I - L {
	switch $w {
	  0 - 1 - 2 - 4 { return [list get_i$w $off] }
	  8             { return [list get_num $off 1 c] }
	  16            { return [list get_num $off 2 s] }
	  32            { return [list get_num $off 4 i] }
	  64            { return [list get_num $off 8 i2] }
	}
      }
      F { return [list get_num $off 4 f] }
      D { return [list get_num $off 8 d] }
    }
  }

  proc fix_handler {rows type} {
    lassign [get_p $rows] size off
    return [numvec $rows $type $size $off]
  }

  proc var_handler {rows type} {
    variable curr
    lassign [get_p $rows] size off
    if {$size > 0} {
      lassign [get_p $rows] s1 o1
    } else {
      lassign {0 0} s1 o1
    }
    set sh [numvec $rows I $s1 $o1]
    set offs {}
    set lens {}
    set pos $off
    for {set i 0} {$i < $rows} {incr i} {
      set n [eval $sh $i]
      lappend offs $pos
      incr pos $n
      if {$type == "S" && $n > 0} { incr n -1 }
      lappend lens $n
    }
    lassign [get_p $rows] msize moff
    if {$msize > 0} {
      set savecurr $curr
      set curr $moff
      set limit [expr {$moff+$msize}]
      for {set row 0} {$curr < $limit} {incr row} {
        incr row [get_v]
	lassign [get_p 1] ms mo
	set offs [lreplace $offs $row $row $mo]
	if {$type == "S" && $ms > 0} { incr ms -1 }
	set lens [lreplace $lens $row $row $ms]
      }
      set curr $savecurr
    }
    return [list get_str [makenode $offs] [makenode $lens]]
  }

  proc sub_handler {rows desc} {
    variable curr
    lassign [get_p $rows] size off
    set savecurr $curr
    set curr $off
    set subs {}
    for {set i 0} {$i < $rows} {incr i} {
      lappend subs [prepare $desc]
    }
    set curr $savecurr
    return [list lindex $subs]
  }

  proc prepare {{desc ""}} {
    if {[get_v] != 0} error
    if {$desc == ""} {
      set desc [layout [get_s [get_v]]]
    }
    
    set rows [get_v]
    set names {}
    set handlers {}
    foreach x $desc {
      if {[llength $x] == 1} {
        lassign [split $x :] name type
      } else {
	set type "V"
	lassign $x name subs
      }
      if {$type == ""} { set type S }
      switch $type {
	I - L -
	F - D { set h [fix_handler $rows $type] }
	B - S { set h [var_handler $rows $type] }
	V     { set h [sub_handler $rows $subs] }
      }
      lappend names $name
      lappend handlers $h
    }

    return [list get_view $rows [makenode $names] [makenode $handlers]]
  }

  proc dbopen {db file} {
    variable dbs
    variable data
    fetch $file
    header
    set dbs($db) [list $file $data [eval [prepare] 0]]
    return $db
  }

  proc dbtree {db} {
    variable dbs
    return [lindex $dbs($db) 2]
  }

  proc access {spec} {
    set x dbtree
    foreach y [split $spec ".!"] {
      set x [eval $x $y]
    }
    return $x
  }

  proc vlen {view} {
    return [lindex $view 1]
  }

  proc vnames {view} {
    variable node
    return $node([lindex $view 2])
  }
}

#source mkcompat.tcl
# MetaKit-in-Tcl compatibility layer - Oct 2001, by Jean-Claude Wippler

namespace eval mkintcl {

  proc mk_file {cmd {db ""} {file ""}} {
    variable dbs
    variable data
    switch $cmd {
      open {
	if {$db == ""} {
	  set r {}
	  foreach {k v} [array get dbs] {
	    lappend r $k [lindex $v 0]
	  }
	  return $r
	}
	if {$file == ""} { error "temp storages not supported" }
	return [dbopen $db $file]
      }
      close {
        unset dbs($db)
	set data "" ;# it may be big
      }
      views {
        return [vnames [dbtree $db]]
      }
      default { error "mk_file $cmd?" }
    }
  }

  proc mk_view {cmd path {a1 ""}} {
    switch $cmd {
      info {
	return [vnames [access $path]]
      }
      layout {
	set layout "NOTYET"
        if {$a1 != "" && $layout != $a1} {
	  error "view restructuring not supported"
	}
	return $layout
      }
      size {
	set len [vlen [access $path]]
        if {$a1 != "" && $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 {![regexp {\d+$} $v n]} { set n -1 }
	return $n
      }
      default { error "mk_cursor $cmd?" }
    }
  }

  proc mk_row {args} {
    error "mk_row?"
  }

  proc mk_get {path args} {
    set view [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 $view]
      set ids 1
    }
    set r {}
    foreach x $args {
      if {$ids} { lappend r $x }
      set v [eval $view $x]
      if {$sized} {
        lappend r [string length $v]
      } else {
        lappend r $v
      }
    }
    return $r
  }

  proc mk_set {args} {
    error "mk_set?"
  }

  proc mk_loop {cursor path args} {
    upvar $cursor v
    lassign $args a1 a2 a3 a4
    set view [access $path]
    set first 0
    set limit [vlen $view]
    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?" }
    }
    for {set i $first} {$i < $limit} {incr i $step} {
      set v $path!$i
      set code [catch [list uplevel 1 $body] err]
      if {$code != 0} { return -code $code $err }
    }
  }

  proc mk_select {cursor args} {
    NOTYET
  }
}

# Wikit listing/extraction tool

set mk "mkintcl::mk_"

if {![file exists wikit.tkd]} {
  puts stderr "Cannot find wikit data file 'wikit.tkd'"
  exit
}

switch -- [lindex $argv 0] {
  -l {
    ${mk}file open db wikit.tkd
    ${mk}loop c db.pages 10 {
      array set a [${mk}get $c]
      if {[string length $a(page)] > 0} {
	set n [${mk}cursor pos c]
        set t [clock format $a(date) -format {%Y/%m/%d %H:%M:%S}]
        puts [format {%5d:  %s  %-15s  %s} $n $t $a(who) $a(name)]
      }
    }
  }
  -s {
    ${mk}file open db wikit.tkd
    ${mk}loop c db.scripts {
      array set a [${mk}get $c]
      set t [clock format $a(date) -format {%Y/%m/%d %H:%M:%S}]
      puts [string repeat "#" 79]
      puts "#  $a(name)  --  $t"
      puts [string repeat "#" 79]
      puts ""
      puts [string trim $a(text)]
      puts ""
    }
  }
  -x {
    ${mk}file open db wikit.tkd
    set sel [lrange $argv 1 end]
    if {[llength $sel] == 0} {
      set n [${mk}view size db.pages]
      for {set i 10} {$i < $n} {incr i} { lappend sel $i }
    }
    foreach n $sel {
      array set a [${mk}get db.pages!$n]
      set t [clock format $a(date) -format {%Y/%m/%d %H:%M:%S}]
      puts "\n\tPage: $n\n\tName: $a(name)\n\tDate: $t\n\tFrom: $a(who)"
      if {[info exists a(refs)]} {
	puts "\tRefs: $a(refs)"
      }
      puts ""
      puts [string repeat "- " 38]
      puts [string trim $a(page)]
      puts [string repeat "==" 38]
    }
  }
  default {
    puts stderr "Usage:
	$argv0 -l             list page titles
	$argv0 -s             extract all scripts to stdout
	$argv0 -x ?num ...?   extract specified (or all) pages to stdout
    "
    exit
  }
}

# vim: ft=tcl