#! /usr/bin/env tclsh
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
package require {ycl chan formulate}
package require {ycl bits struct}
aliases {
{ycl bits}
{ycl chan} {
formulate
}
{ycl chan chan} {
cmp
}
{ycl eval} {
upcall
}
{ycl math} {
bisect
expr
}
{ycl ns} {
nsjoin join
normalize
which
}
{ycl proc} {
alias
lambda
}
}
namespace ensemble create -command lengths -map {
iterate {{lengths iterate}}
}
namespace ensemble create -command {lengths iterate} -map {
chan {{lengths iterate chan}}
general {{lengths iterate general}}
}
namespace eval lengths {}
proc {lengths iterate general} {name index range offset} {
set state [nsjoin [namespace current] lengths [info cmdcount]]
namespace eval $state [list set offset $offset]
set name [upcall 1 normalize $name]
upcall 1 [which alias] $name {*}[lambda {routine state index} {
namespace upvar $state offset offset
lassign [bits struct decode length general \
$index $offset] lengthlength type length
if {$lengthlength == 0} {
rename $routine {}
return -code break
}
set offset [expr {$offset + $lengthlength}]
return $length
} $name $state $index]
upcall 1 [which trace] add command $name delete [
lambda {state oldname newname op} {
namespace delete $state
} $state]
}
proc {lengths iterate chan} {name chan offset} {
set index $chan
formulate index index
set range $chan
formulate range range
upcall 1 lengths iterate general $name $index $range $offset
}
proc offsets {lengths offsetschan width} {
chan configure $offsetschan -translation binary
set current 0
switch $width {
8 {
set type w
}
default {
error [list {unknown width} $width]
}
}
while 1 {
set length [{*}$lengths]
set bcurrent [binary format $type $current]
puts -nonewline $offsetschan $bcurrent
incr current $length
}
flush $offsetschan
return
}
proc verifyoffsets {chan offsetschan} {
set tmpchan [file tempfile file]
chan configure $tmpchan -translation binary
try {
seek $offsetschan 0 start
set num [read $offsetschan 8]
binary scan $num[set num {}] w num
while 1 {
set nextnum [read $offsetschan 8]
binary scan $nextnum[set nextnum {}] w nextnum
seek $chan $num start
if {$nextnum eq {}} {
set data [read $chan]
} else {
expr size {$nextnum - $num}
set data [read $chan $size]
}
puts -nonewline $tmpchan $data
if {$nextnum eq {}} {
break
}
set num $nextnum
}
seek $chan 0 start
seek $tmpchan 0 start
cmp $chan $tmpchan
} finally {
close $tmpchan
file delete -force $file
}
}