#! /bin/env tclsh
package require {ycl test}
proc suite_main {} {
package require sqlite3
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl dict deep}
{ycl eval} {
block
}
{ycl list} {
sl
}
{ycl parser interp} {
parse
}
{ycl test data} {
bytes
startrek
}
}
namespace import [yclprefix]::db::sqlite::util::explain_pretty
package require {ycl string chan}
if {[namespace which [namespace current]::schan] eq {}} {
namespace import [yclprefix]::string::chan
rename chan schan
}
namespace import [yclprefix]::struct::tree
namespace import [yclprefix]::test::cleanup1
[yclprefix]::test::init
set tprefix tree1
set setup1 {
variable tree1
[tree .new tree1] .init dbitemprefix $tprefix
}
set setup2 $setup1
append setup2 {
tree1 node tree {} $tree1
tree1 node forge {} one seven
}
set setup3 $setup1
append setup3 {
tree1 read [startrek]
}
set setup4 $setup1
append setup4 {
set res {}
set n1 [tree1 node new {} n1]
set n1a [tree1 node new $n1 n1a]
set n1b [tree1 node new $n1 n1b]
}
set setup5 $setup1
append setup5 {
set one [tree1 node new {} one]
lappend res {one is top} [expr {[tree1 node up& $one] eq {}}]
set two [tree1 node new {} two]
lappend res {two is top} [expr {[tree1 node up& $two] eq {}}]
set three [tree1 node new $one three]
lappend res {three parent is one} [expr {$one == [tree1 node up& $three]}]
set three2 [tree1 node pivot $one three]
lappend res {pivot from one to three is three} [expr {$three == $three2}]
set four [tree1 node link $three $two]
}
variable tree1 {
one {}
two {}
three {
four {}
five {}
}
}
test dbconn {} -setup {} -body {
sqlite3 db1 :memory:
db1 eval {
create table t1 (
c1
, c2
)
; insert into t1 values ("value 1" ,"value 2")
}
[tree .new tree1] .init dbconn db1
tree1 node tree {} $tree1
set node [tree1 node pivot {} three]
lappend res [tree1 node last $node]
lappend res [db1 eval {select c1 ,c2 from t1}]
return $res
} -cleanup [cleanup1] -result [sl {
five
{{value 1} {value 2}}
}]
test descendants_refs {} -setup $setup3 -body {
set res {}
set node [tree1 node pivot {} name]
set namenode [tree1 node pivot {} name]
tree1 descendants refs $namenode {
upvar res res
lappend res [tree1 node val $node]
}
return $res
} -cleanup [cleanup1] -result [sl {
name name name name name name name
}]
test forge {} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} one two] node created
lappend res $created [tree1 node val $node]
return $res
} -cleanup [cleanup1] -result [sl {
2 two
}]
test forge_deep {} -setup $setup1 -body {
set res {}
set node [tree1 node new {} 0]
set start $node
lappend path 0
for {set i 0} {$i < 100} {incr i} {
set node [tree1 node new $node $i]
lappend path $i
}
set pathlist [tree1 node path $node]
lappend res [expr {[tree1 node path $node] eq $path}]
set deep [tree1 node pivot $start {*}[lrange $path 1 end]]
return $res
} -cleanup [cleanup1] -result [sl {
1
}]
test forge_node {} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} one two three] three created
lappend res $created [tree1 node last {} one]
lappend res [tree1 node val $three]
set one [tree1 node pivot {} one]
set two [tree1 node pivot {} one two]
lassign [tree1 node forge $one two three four] four created
lappend res $created [tree1 node last $two] [tree1 node val $four]
return $res
} -cleanup [cleanup1] -result [sl {
3 two three
1 three four
}]
test forge_node_childmatchesparent {} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} one] one created
lappend res $created [tree1 node val $one]
lassign [tree1 node forge $one one] oneone created
lappend res $created [tree1 node val $oneone]
return $res
} -cleanup [cleanup1] -result [sl {
1 one
1 one
}]
test forge_novals {} -setup $setup2 -body {
set res {}
lassign [tree1 node forge {}] node created
lappend res $node $created
return $res
} -cleanup [cleanup1] -result [sl {
{} 0
}]
test forge_top {} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} one two] node created
lappend res [expr {$node >= 0}] $created
return $res
} -cleanup [cleanup1] -result [sl {
1 2
}]
test clear {} -setup $setup3 -body {
set enterprise [tree1 node pivot {} {U.S.S. Enterprise}]
set children [tree1 node ls $enterprise]
lappend res [llength $children]
tree1 node clear $enterprise
set enterprise [tree1 node pivot {} {U.S.S. Enterprise}]
set children [tree1 node ls $enterprise]
lappend res [llength $children]
return $res
} -cleanup [cleanup1] -result [sl {
1 0
}]
test node_appears {} -setup $setup3 -body {
set st [tree1 node pivot {} {Star Trek}]
set captain [tree1 node pivot {} {captain}]
set link1 [tree1 node link {} $captain]
set link2 [tree1 node link $st $link1]
set res1 {}
tree1 node appears& $st $captain {
upvar res1 res1
lappend res1 [tree1 node path $node]
}
lappend res $res1
return $res
} -cleanup [cleanup1] -result [sl {
{{{Star Trek} captain} {{Star Trek} {} roles captain}}
}]
test node_converge {} -setup $setup1 -body {
set res {}
set onenode [tree1 node new {} one]
set twonode [tree1 node new {} two ]
set threenode [tree1 node new $twonode three]
set fournode [tree1 node new {} four]
set link1 [tree1 node link $threenode $onenode]
set link2 [tree1 node link $link1 $fournode]
set path [tree1 node converge& $link2 $twonode]
lappend res [expr {
[lindex $path 0] == $threenode
&& [lindex $path 1] == $link1
&& [lindex $path 2] == $link2
}]
set path [tree1 node converge $link2 $twonode]
lappend res $path
return $res
} -cleanup [cleanup1] -result [sl {
1 {three one four}
}]
test node_cp {} -setup $setup3 -body {
set res {}
set node [tree1 node pivot {} {Star Trek}]
set node2 [tree1 node pivot {} list]
set routine [list ::apply [list [list node args] {
tree1 node walk $node {
yield [list $node $up $value]
}
return -code break
} [namespace current]]]
tree1 node cp $node $node2
coroutine c1 {*}$routine $node
set down [tree1 node down& $node2]
coroutine c2 {*}$routine $down
set matched 1
while 1 {
lassign [c1] node1 up value1
lassign [c2] node2 up value2
if {[tree1 node islink $node1]} {
if {![tree1 node islink $node2]} {
lappend res {value node became link node}
}
} else {
if {[tree1 node islink $node2]} {
lappend res {link node became value node}
}
}
if {$value2 ne $value1} {
set matched 0
}
}
lappend res $matched
return $res
} -cleanup [cleanup1] -result [sl {
1
}]
test node_ddict {} -setup $setup3 -body {
set res {}
set res1 [tree1 node ddict {}]
lappend res length [llength $res1]
set res2 $res1
deep get res2 {Star Trek} name value
lappend res {Star Trek name value} $res2
set res2 $res1
deep get res2 translation kind
lappend res {translation kind} $res2
set res2 $res1
set status [catch {deep get res2 ownself} cres]
lappend res ownself $status $cres
return $res
} -cleanup [cleanup1] -result [sl {
length 62
{Star Trek name value} {Star Trek}
{translation kind} {Chinese Russian}
ownself 1 empty
}]
test node_empty {} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} one] one
lassign [tree1 node forge {} one two] two
lappend res [tree1 node empty? $two]
lappend res [tree1 node empty? $one]
return $res
} -cleanup [cleanup1] -result [sl {
1 0
}]
test node_exists {} -setup $setup3 -body {
lappend res [tree1 node exists {} {Star Trek}]
lappend res [tree1 node exists {} {something fake}]
set st [tree1 node pivot {} {Star Trek}]
set fake [tree1 node pivot? $st name value]
lappend res [tree1 node exists $st name value]
lappend res [tree1 node exists $st name fake]
return $res
} -cleanup [cleanup1] -result [sl {
1 0 1 0
}]
test node_last {} -setup $setup2 -body {
set res {}
lappend res [tree1 node last {} three]
return $res
} -cleanup [cleanup1] -result [sl {
five
}]
test node_last_bytes {} -setup $setup1 -body {
set res {}
set data [bytes]
lassign [tree1 node forge {} one] one
set datanode [tree1 node set $one $data {two three}]
lappend res [tree1 node last $one $data]
return $res
} -cleanup [cleanup1] -result [sl {
{two three}
}]
test node_last_root {} -setup $setup2 -body {
set res {}
lappend res [tree1 node last]
return $res
} -cleanup [cleanup1] -result [sl {
three
}]
test node_last_nolast {} -setup $setup2 -body {
set res {}
set status [catch {tree1 node last {} two} cres copts]
lappend res $status $cres
return $res
} -cleanup [cleanup1] -result [sl {
1 [list {no results}]
}]
test node_last& {} -setup $setup2 -body {
set res {}
for {set i 0} {$i < 10} {incr i} {
tree1 node last& {} three
}
set three [tree1 node last& {} three]
lappend res [tree1 node val $three]
lappend res [tree1 nodelast&cache stats]
return $res
} -cleanup [cleanup1] -result [sl {
five
{hits 10 misses 1 size 1}
}]
test node_last&_root {} -setup $setup2 -body {
set res {}
set lastnode [tree1 node last&]
lappend res [tree1 node val $lastnode]
return $res
} -cleanup [cleanup1] -result [sl {
three
}]
test node_last&_nolast {} -setup $setup2 -body {
set res {}
set status [catch {tree1 node last& {} two} cres copts]
lappend res $status $cres
return $res
} -cleanup [cleanup1] -result [sl {
1 [list {no results}]
}]
test node_leaves {} -setup $setup1 -body {
set res {}
set onenode [tree1 node new {} one]
set twonode [tree1 node new {} two ]
set threenode [tree1 node new $twonode three]
set fournode [tree1 node new $twonode four]
set fivenode [tree1 node new {} five]
set link1 [tree1 node link $threenode $onenode]
set link2 [tree1 node link $link1 $fivenode]
set leaves [tree1 node leaves& $twonode]
lappend res [llength $leaves]
lappend res [expr {[lindex $leaves 0] eq $link2}]
lappend res [expr {[lindex $leaves 1] eq $fournode}]
lappend res [tree1 node leaves $twonode]
return $res
} -cleanup [cleanup1] -result [sl {
2 1 1 {five four}
}]
test node_link_ls {} -setup $setup5 -body {
lappend res {four is} [tree1 node val $four]
lappend res {ls three} [tree1 node ls $three]
return $res
} -cleanup [cleanup1] -result [sl {
{one is top} 1
{two is top} 1
{three parent is one} 1
{pivot from one to three is three} 1
{four is} two
{ls three} two
}]
test node_link_ls2 {} -setup $setup3 -body {
set res {}
set node [tree1 node pivot {} {Star Trek} name value]
lappend res [tree1 node val $node]
lappend res [tree1 node ls $node]
return $res
} -cleanup [cleanup1] -result [sl {
value {Star Trek}
}]
test node_link_pivot {} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} one] one
lassign [tree1 node forge $one two ] two
lassign [tree1 node forge {} three four] four
lassign [tree1 node forge {} five six] six
set link1 [tree1 node link $four $one]
set link2 [tree1 node link $six $link1]
set target1 [tree1 node target $link1]
set target2 [tree1 node target $link2]
lappend res {link2 references link1} [expr {$target2 eq $link1}]
return $res
} -cleanup [cleanup1] -result [sl {
{link2 references link1} 1
}]
test node_link_top {} -setup $setup2 -body {
set res {}
set four [tree1 node pivot {} three four]
tree1 node forge {} nine
set four [tree1 node link {} $four]
lappend res {is link} [tree1 node islink $four]
lassign [tree1 node forge {} eight] eight
tree1 node ls {} {
upvar res res
lappend res $value
}
return $res
} -cleanup [cleanup1] -result [sl {
{is link} 1
. one two three nine four eight
}]
test node_link_resolve {} -setup $setup2 -body {
set res {}
set four [tree1 node pivot {} three four]
set two [tree1 node pivot {} two]
tree1 node link $two $four
tree1 node ls $two {
upvar res res
lappend res $value
}
return $res
} -cleanup [cleanup1] -result [sl {
four
}]
test node_linkval_set {} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} Dryden] dryden
lassign [tree1 node forge {} William] william
set node [tree1 node set {} author Dryden]
set node [tree1 node pivot {} author]
set author [tree1 node pivot {} author]
set node [tree1 node linkval {{} author} $william]
lappend res [tree1 node val $author]
return $res
} -cleanup [cleanup1] -result [sl {
William
}]
test node_ls {} -setup $setup3 -body {
set ls [tree1 node ls {}]
foreach word {captain 星際爭霸戰} {
lappend res $word [expr {$word in $ls}]
}
return $res
} -cleanup [cleanup1] -result [sl {
captain 1 星際爭霸戰 1
}]
foreach \
type {_spec_missing _spec_empty _spec_remap _spec_array} \
spec [list {} [list {}] [list {value current}] s] \
varname {value value current s(value)} {
try [string map [list @type@ $type @spec@ $spec @varname@ $varname] {
test node_ls_script@type@ {} -setup $setup3 -body {
set res {}
tree1 node ls {} @spec@ {
upvar res res
if {$@varname@ in {captain 星際爭霸戰}} {
# also test that there is a local scope that is preserved across
# iterations
lappend res [incr i] $@varname@
}
}
return [lsort $res]
} -cleanup [cleanup1] -result [sl {
1 2 captain 星際爭霸戰
}]
}]
}
test node_ls_pivot {} -setup $setup4 -body {
set res [tree1 node ls [list {} n1]]
return $res
} -cleanup [cleanup1] -result [sl {
n1a n1b
}]
foreach \
type {_spec_missing _spec_empty _spec_param _spec_array} \
spec [list {} [list {}] [list {value myvalue}] s] \
varname {value value myvalue s(value)} {
try [string map [list @type@ $type @spec@ $spec @varname@ $varname] {
test node_ls_pivot_script@type@ {} -setup $setup4 -body {
set res2 {}
tree1 node ls [list {} n1] @spec@ {
upvar res2 res2
lappend res2 $@varname@
}
lappend res $res2
return $res
} -cleanup [cleanup1] -result [sl {
{n1a n1b}
}]
}]
}
test node_ls& {} -setup $setup3 -body {
set nodes [tree1 node ls& {}]
set novalue {}
set topnodes [tree1 db eval "
select node from ${tprefix}tree where node = up and value != '.'
"]
set topdict {}
foreach node $topnodes {
dict set topdict $node 0
}
set values {}
foreach node $nodes {
dict incr dict $node -1
try {tree1 node val $node} on ok val {
lappend values $val
} on error {tres copts} {
lappend novalue $node
}
}
set notseen {}
set multiple {}
foreach {key val} $topdict {
if {$val > 0} {
lappend notseen $node
} elseif {$val < 0} {
lappend multiple $node
}
}
lappend res {not seen} $notseen
lappend res multiple $multiple
# the three cyclical links
lappend res novalue [llength $novalue]
foreach word {captain 星際爭霸戰} {
lappend res $word [expr {$word in $values}]
}
return $res
} -cleanup [cleanup1] -result [sl {
{not seen} {} multiple {} novalue 3 captain 1 星際爭霸戰 1
}]
foreach \
type {_spec_missing _spec_empty _spec_param _spec_array} \
spec [list {} [list {}] [list {node mynode}] s] \
varname {node node mynode s(node)} {
try [string map [list @type@ $type @spec@ $spec @varname@ $varname] {
test node_ls&_node@type@ {} -setup $setup3 -body {
set path {{} {Gene Roddenberry}}
set nodes1 [tree1 node ls& $path]
set values1 [tree1 node ls $path]
set nodes2 {}
set values2 {}
set novalue {}
tree1 node ls& $path @spec@ {
upvar nodes2 nodes2 values2 values2 novalue novalue
lappend nodes2 $node
try {tree1 node val $@varname@} on ok val {
lappend values2 $val
} on error {tres copts} {
lappend novalue $node
}
}
lappend res {no value} [llength $novalue]
lappend res {lengths are equal} [expr {
[llength $nodes2] == [llength $nodes1]
}]
lappend res $values1 $values2
return $res
} -cleanup [cleanup1] -result [sl {
{no value} 0
{lengths are equal} 1
{name hypocoristicon {}}
{name hypocoristicon {}}
}]
test node_ls&_script@type@ {} -setup $setup3 -body {
set novalue {}
set values {}
tree1 node ls& {} @spec@ {
upvar novalue novalue values values
try {tree1 node val $@varname@} on ok val {
lappend values $val
} on error {tres copts} {
lappend novalue $node
}
}
lappend res {no value} [llength $novalue]
foreach word {captain 星際爭霸戰} {
lappend res $word [expr {$word in $values}]
}
return $res
} -cleanup [cleanup1] -result [sl {
{no value} 3 captain 1 星際爭霸戰 1
}]
test node_ls&_pivot_script@type@ {} -setup $setup3 -body {
set novalue {}
tree1 node ls& {{} {Gene Roddenberry}} @spec@ {
upvar novalue novalue values values
try {tree1 node val $@varname@} on ok val {
lappend values $val
} on error {tres copts} {
lappend novalue $node
}
}
lappend res {no value} [llength $novalue]
lappend res $values
return $res
} -cleanup [cleanup1] -result [sl {
{no value} 0 {name hypocoristicon {}}
}]
}]
}
::apply [list {} {
upvar setup1 setup1 type type tprefix tprefix
foreach {type path result} [list \
nopath {} [sl {
[list {}] name
}] \
empty [list {}] [sl {
[list {}] name
}]] {
test node_new_$type {} -setup $setup1 -body {
set res {}
set node [tree1 node new {*}$path]
tree1 node set $node name archibald
lappend res [tree1 node path $node]
tree1 node ls $node {
upvar res res
lappend res $value
}
return $res
} -cleanup [cleanup1] -result $result
}
} [namespace current]]
test node_new_badpath {} -setup $setup1 -body {
set res {}
catch {tree1 node new {{} one two three}} res1
lappend res $res1
return $res
} -cleanup [cleanup1] -result [sl {
{{no such path} node {} path {one two three}}
}]
test node_forth {
forth doesn't go down
} -setup $setup3 -body {
set res {}
set node [tree1 node pivot {} name]
set st [tree1 node pivot {} {Star Trek}]
set roddenberry [tree1 node forth& $st]
set val [tree1 node val $roddenberry]
lappend res $val
return $res
} -cleanup [cleanup1] -result [sl {
{Gene Roddenberry}
}]
test node_nonull {} -setup $setup1 -body {
set node 100
set parent 100
# there is no variable named "value"
catch {
tree1 db eval [string map [list @@ [tree1 dbitemprefix]] {
insert into @@tree values (
$node, $parent, $value
)
}]
} cres copts
lappend res {not null constraint} [
string match {NOT NULL constraint failed:*} $cres]
return $res
} -cleanup [cleanup1] -result [sl {
{not null constraint} 1
}]
test node_pivot_node {} -setup $setup3 -body {
set st [tree1 node pivot {} {Star Trek}]
set val [tree1 node pivot $st name value]
lappend res [tree1 node last $val]
return $res
} -cleanup [cleanup1] -result [sl {
Trek
}]
test node_forge_bad_node {
An attempt to forge a node starting from a bad node handle fails
} -setup $setup1 -body {
tree1 node forge bogus one two three
return $res
} -cleanup [cleanup1] -returnCodes 1 -result [sl {
{no such node} bogus
}]
test node_forge_link {
new nodes are created under the link rather than under the thing the
link refers to
} -setup $setup5 -body {
lappend res {four is} [tree1 node val $four]
lappend res {ls three} [tree1 node ls $three]
set topllink [tree1 node link {} $three]
lassign [tree1 node forge {} three] toplink2 created
lappend res {saw top-level link} [expr {$created == 0}]
lassign [tree1 node forge $three two] twolink created
lappend res {forge tree two saw the existing link} [expr {$created == 0}]
lappend res {link to two is different from two} [expr {$two != $twolink}]
lassign [tree1 node forge $three two five] five created
lappend res {created under three} $created
set nodes [tree1 node ls& $three]
#lappend res {}
lassign [tree1 node forge $five six seven] seven created
lappend res {created under five} $created
lappend res {up from five is link to two} [
expr {[tree1 node up& $five] == $twolink}]
return $res
} -cleanup [cleanup1] -result [sl {
{one is top} 1
{two is top} 1
{three parent is one} 1
{pivot from one to three is three} 1
{four is} two
{ls three} two
{saw top-level link} 1
{forge tree two saw the existing link} 1
{link to two is different from two} 1
{created under three} 1
{created under five} 2
{up from five is link to two} 1
}]
test node_pivot_node_pivottargetmatchesvalue {} -setup $setup1 -body {
set res {}
set zero [tree1 node new {} 0]
set one [tree1 node pivot? $zero 0]
lappend res [expr {$one eq {}}]
return $res
} -cleanup [cleanup1] -result [sl {
1
}]
test node_pivot_numeric {} -setup $setup1 -body {
set res {}
set number 9
## it shouldn't be necessary to add an internal numeric representation
#expr {$number + 0}
set set [tree1 node forge {} paths / one $number two]
set paths [tree1 node pivot {} paths]
set two [tree1 node pivot $paths / one $number two]
lappend res [tree1 node val $two]
return $res
} -cleanup [cleanup1] -result [sl {
two
}]
test node_refs {} -setup $setup3 -body {
set res {}
set node [tree1 node pivot {} name]
set st [tree1 node pivot {} {Star Trek}]
set first [tree1 node down& $st]
set next [tree1 node forth& $first]
set first1 [tree1 node down& $next]
# this is a link to a link to $node
set link1 [tree1 node link $first1 $first]
set refs {}
foreach {ref1 up} [tree1 node refs $node] {
lappend refs $ref1
}
lappend res [llength $refs]
lappend res [expr {$link1 in $refs}]
set translation [tree1 node pivot {} translation]
set referenced [tree1 node referenced? $translation]
lappend res {translation referenced?} $referenced
set referenced [tree1 node referenced? $node]
lappend res {name referenced?} 1
return $res
} -cleanup [cleanup1] -result [sl {
8 1 {translation referenced?} 0 {name referenced?} 1
}]
test node_resolve {} -setup $setup3 -body {
set res {}
set count1 0
set vals1 {}
set links 0
tree1 node walk {} {
upvar links links res res
if {$value eq {William Shatner}} {
if {[tree1 node islink $node]} {
incr links
}
lappend res [tree1 node val $node]
}
}
lappend res $links
return $res
} -cleanup [cleanup1] -result [sl {
{William Shatner}
{William Shatner}
{William Shatner}
2
}]
test node_rm {} -setup $setup3 -body {
set res {}
set ls [tree1 node ls {}]
set node [tree1 node pivot {} 星際爭霸戰]
lappend res [expr {$node >= 0}]
tree1 node rm $node
lappend res [catch {tree1 node pivot {} 星際爭霸戰} cres copts]
lappend res $cres
return $res
} -cleanup [cleanup1] -result [sl {
1 1 {{no such path} node {} path 星際爭霸戰}
}
]
test node_rm_pivot {} -setup $setup3 -body {
set res {}
set ls [tree1 node ls {}]
set node [tree1 node pivot {} 星際爭霸戰]
lappend res [expr {$node >= 0}]
tree1 node rm {} 星際爭霸戰
lappend res [catch {tree1 node pivot {} 星際爭霸戰} cres copts]
lappend res $cres
return $res
} -cleanup [cleanup1] -result [sl {
1 1 {{no such path} node {} path 星際爭霸戰}
}]
test node_rm_recurse {
removing a node removes all its children
} -setup $setup2 -body {
set res {}
set one [tree1 node pivot {} one]
set seven [tree1 node pivot $one seven]
tree1 node ls& $one {
upvar count count
incr count
}
lappend res {nodes under} $count
set size [tree1 size]
tree1 node rm $one
set size2 [tree1 size]
lappend res {node one exists} [tree1 node exists $one]
lappend res {node seven exists} [tree1 node exists $seven]
lappend res {size decreased by} [expr {$size - $size2}]
return $res
} -cleanup [cleanup1] -result [sl {
{nodes under} 1
{node one exists} 0
{node seven exists} 0
{size decreased by} 2
}]
test node_rm_value_remove {} -setup $setup3 -body {
set res {}
set count [tree1 values count]
set node [tree1 node pivot {} 星際爭霸戰]
tree1 node rm $node
set count2 [tree1 values count]
lappend res [expr {$count - 1 == $count2}]
return $res
} -cleanup [cleanup1] -result [sl {
1
}]
test node_path& {} -setup $setup2 -body {
set res {}
set five [tree1 node pivot {} three five]
set path [tree1 node path& $five]
foreach node $path {
lappend res [tree1 node val $node]
}
return $res
} -cleanup [cleanup1] -result [sl {
three five
}]
foreach \
type {spec_missing _spec_empty _spec_param _spec_array} \
spec [list {} [list {}] [list {node mynode}] s] \
varname {node node mynode s(node)} {
try [string map [list @type@ $type @spec@ $spec @varname@ $varname] {
test node_path&_script@type@ {} -setup $setup2 -body {
set res {}
set five [tree1 node pivot {} three five]
tree1 node path& $five @spec@ {
upvar res res
lappend res [tree1 node val $@varname@]
}
return $res
} -cleanup [cleanup1] -result [sl {
three five
}]
}]
}
test node_path {} -setup $setup2 -body {
set res {}
set node [tree1 node pivot {} three five]
lappend res [tree1 node path $node]
return $res
} -cleanup [cleanup1] -result [sl {
{three five}
}]
foreach \
type {spec_missing _spec_empty _spec_param _spec_array} \
spec [list {} [list {}] [list {value myvalue}] s] \
varname {value value myvalue s(value)} {
try [string map [list @type@ $type @spec@ $spec @varname@ $varname] {
test node_path_script$type {} -setup $setup2 -body {
set res {}
tree1 node path [list {} three five] @spec@ {
upvar res res
lappend res $@varname@
}
return $res
} -cleanup [cleanup1] -result [sl {
three five
}]
}]
}
test node_pivot_nosuchnode {} -setup $setup2 -body {
set res {}
tree1 node pivot 999
} -cleanup [cleanup1] -returnCodes 1 -result [sl {
{no such path} node 999 path {}
}]
test node_pivot_link {
pivots to the link
not to the link target
} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} one two] twonode
lassign [tree1 node forge {} three four] fournode
set linknode [tree1 node link $fournode $twonode]
set target [tree1 node target $linknode]
set testnode [tree1 node pivot $fournode two]
lappend res [expr {$target eq $twonode}]
lappend res [expr {$testnode eq $linknode}]
lappend res [expr {$testnode ne $twonode}]
return $res
} -cleanup [cleanup1] -result [sl {
1 1 1
}]
test node_pivot_self {} -setup $setup2 -body {
set res {}
set node [tree1 node pivot {} two]
lappend res [tree1 node val $node]
set node [tree1 node pivot $node]
lappend res [tree1 node val $node]
return $res
} -cleanup [cleanup1] -result [sl {
two two
}]
test node_pretty {} -setup $setup3 -body {
set res {}
set count1 0
set vals1 {}
set count1 [tree1 db onecolumn {
select count(*) as count from tree1tree
}]
tree1 node walk {} {
upvar vals1 vals1
lappend vals1 [string trim [list $node $up $ref $value]]
}
set chan [schan open access w+ data {}]
tree1 node pretty {} chan $chan
seek $chan 0
set pretty [read $chan]
set count2 0
set vals2 {}
parse $pretty ::apply [list args {
upvar count2 count2 vals2 vals2
incr count2
lappend vals2 [string trim $args]
} [namespace current]]
lappend res [expr {$count1 == $count2}]
lappend res [expr {[llength $vals2] == $count1}]
set matched 1
foreach val $vals2 {
if {$val ni $vals1} {
set matched 0
break
}
}
lappend res $matched
return $res
} -cleanup [cleanup1] -result [sl {
1 1 1
}]
test node_set {} -setup $setup1 -body {
set res {}
set node [tree1 node set {} author Dryden]
lappend res [tree1 node last {} author]
return $res
} -cleanup [cleanup1] -result [sl {
Dryden
}]
test node_set_existing {} -setup $setup1 -body {
set res {}
set node [tree1 node set {} author Dryden]
set pivot1 [tree1 node pivot {} author]
lappend res [tree1 node last {} author]
set node [tree1 node set {} author William]
set pivot2 [tree1 node pivot {} author]
lappend res [tree1 node last {} author]
lappend res [expr {$pivot1 == $pivot2}]
return $res
} -cleanup [cleanup1] -result [sl {
Dryden William 1
}]
foreach \
type {spec_missing _spec_empty _spec_param _spec_array} \
spec [list {} [list {}] [list {value myvalue}] s] \
varname {value value myvalue s(value)} {
try [string map [list @type@ $type @spec@ $spec @varname@ $varname] {
test node_traverse_top@type@ {
traverse a top node
} -setup $setup2 -body {
set res {}
set one [tree1 node pivot {} one]
tree1 node traverse $one @spec@ {
upvar res res
lappend res $@varname@
}
return $res
} -cleanup [cleanup1] -result [sl {
one seven
}]
}]
}
test node_val_set {} -setup $setup1 -body {
set res {}
set node [tree1 node set {} author Dryden]
tree1 node val $node William
#lappend res [tree1 node val $node]
#return $res
} -cleanup [cleanup1] -result [sl {
William
}]
test node_valueid {
pivots to the link
not to the link target
} -setup $setup1 -body {
set res {}
lassign [tree1 node forge {} one two] twonode
lassign [tree1 node forge {} three four] fournode
set link1 [tree1 node link $fournode $twonode]
set link2 [tree1 node link $fournode $link1]
set v1 [tree1 node valueid $twonode]
set v2 [tree1 node valueid $link1]
set v3 [tree1 node valueid $link2]
lappend res [expr {$v1 eq $v2 && $v1 eq $v3}]
return $res
} -cleanup [cleanup1] -result [sl {
1
}]
block {
upvar setup1 setup1 tprefix tprefix tunit tunit
set tunit [lindex [time {
for {set i 0} {$i < 100} {incr i} {
set a $i
}
} 1] 0]
set maketree {
set res1 [lindex [time {
set size1 [tree1 size]
set count 0
for {set i 0} {$i < 12} {incr i} {
lassign [tree1 node forge {} $i] node1 created
if {!$created} {
error [list {node not created} 1 $i]
}
incr count
for {set j 0} {$j < 11} {incr j} {
lassign [tree1 node forge $node1 $j] node2 created
if {!$created} {
error [list {node not created} 2 $i $j]
}
incr count
for {set k 0} {$k < 10} {incr k} {
lassign [tree1 node forge $node2 $k] node3 created
if {!$created} {
error [list {node not created} 3 $i $j $k]
}
incr count
for {set l 0} {$l < 9} {incr l} {
lassign [
tree1 node forge $node3 $l] node4 created
if {!$created} {
error [list {node not created} 4 $i $j $k $l]
}
incr count
}
}
}
set targetsize [expr {$size1 + $count}]
if {[tree1 size] != $targetsize} {
error [
list {wrong number nodes} [tree1 size] $targetsize]
}
}
} 1] 0]
set perform1 [expr {$res1 / $tunit}]
}
set maketree2 {
set res1 [lindex [time {
set size1 [tree1 size]
set count 0
for {set i 0} {$i < 12} {incr i} {
for {set j 0} {$j < 11} {incr j} {
for {set k 0} {$k < 10} {incr k} {
for {set l 0} {$l < 9} {incr l} {
lassign [
tree1 node forge {} $i $j $k $l
] node created
if {$created} {
incr count $created
} else {
error [
list {node not created} 4 $i $j $k $l]
}
}
}
}
set targetsize [expr {$size1 + $count}]
if {[tree1 size] != $targetsize} {
error [
list {wrong number nodes} [tree1 size] $targetsize]
}
}
} 1] 0]
set perform1 [expr {$res1 / $tunit}]
}
set maketree3 {
set res1 [lindex [time {
set size1 [tree1 size]
set count 0
for {set i 0} {$i < 2} {incr i} {
lassign [tree1 node forge {} $i] node created
incr count $created
if {!$created} {
error [list {node not created} 1 $i]
}
for {set j 0} {$j < 3} {incr j} {
for {set k 0} {$k < 4} {incr k} {
for {set l 0} {$l < 1000} {incr l} {
lassign [
tree1 node forge $node $j $k $l
] node created
if {$created} {
incr count $created
} else {
error [
list {node not created} 4 $i $j $k $l]
}
}
}
}
set targetsize [expr {$size1 + $count}]
if {[tree1 size] != $targetsize} {
error [
list {wrong number nodes} [tree1 size] $targetsize]
}
}
} 1] 0]
set perform1 [expr {$res1 / $tunit}]
}
variable perform1 {}
test performance_set {} -setup $setup1 -body {
set res1 [lindex [time {
try $maketree
} 1] 0]
lappend res [list less than 50000?] [
expr {$perform1 < 50000 ? 1 : $perform1}]
lappend res {size is correct?} [
expr {[tree1 size] == $size1 + $count}]
return $res
} -cleanup [cleanup1] -result [sl {
{less than 50000?} 1
{size is correct?} 1
}]
test performance_node_checkvalue_nomatch {
checks the performance of the q_check_value and q_pivot_top_simple
by searching for a nonexisting value under a node having a large
number of children
} -setup $setup1 -body {
lassign [tree1 node forge {} node1] node1
set res {}
for {set i 0} {$i < 131072} {incr i} {
set lastlink [tree1 node new $node1 hello]
}
lassign [time {
for {set i 0} {$i < 262144} {incr i} {
set found [tree1 checkvalue $node1 goodbye]
}
} 1] ms
set elapsed [expr {$ms / $tunit}]
lappend res {elapsed time of} $elapsed \
{is 265000 standard units or less} [expr {$elapsed < 265000}]
return $res
} -cleanup [cleanup1] -match glob -result [sl {
{elapsed time of} * {is 265000 standard units or less} 1
}]
test performance_node_forge {
is node_forge performant enough
} -setup $setup1 -body {
set res1 [lindex [time {
try $maketree2
} 1] 0]
lappend res [list less than 50000?] [
expr {$perform1 < 50000 ? 1 : $perform1}]
lappend res {size is correct?} [
expr {[tree1 size] == $size1 + $count}]
return $res
} -cleanup [cleanup1] -result [sl {
{less than 50000?} 1
{size is correct?} 1
}]
test performance_node_forge_wide {
} -setup $setup1 -body {
set res1 [lindex [time {
try $maketree3
} 1] 0]
lappend res [list less than 50000?] [
expr {$perform1 < 50000 ? 1 : $perform1}]
lappend res {size is correct?} [
expr {[tree1 size] == $size1 + $count}]
return $res
} -cleanup [cleanup1] -result [sl {
{less than 50000?} 1
{size is correct?} 1
}]
test performance_node_forge_longname {
} -setup $setup1 -body {
set size1 [tree1 size]
set count 10000
set digit 0123456789
set alpha abcdefghijklmnopqrstuvwxyz
set pathname $alpha/$digit/$alpha/$digit/$alpha/$digit\${i}[
string repeat $alpha$digit 4]
set len1 [expr {[llength [split $pathname /]] - 1}]
set res1 [lindex [time [string map [list @pathname@ $pathname] {
try {
lassign [tree1 node forge {} paths] paths
incr len1
for {set i 0} {$i < $count} {incr i} {
set path [split @pathname@ /]
tree1 node forge $paths {*}$path
}
}
}] 1] 0]
lappend res {size is correct?} [expr {
[tree1 size] == $size1 + $count + $len1
}]
set perform1 [expr {$res1 / $tunit}]
lappend res [list performance is in the ballpark of 325000?] [
expr {$perform1 < 325000 ? 1 : $perform1}]
return $res
} -cleanup [cleanup1] -result [sl {
{size is correct?} 1
{performance is in the ballpark of 325000?} 1
}]
test performance_walk_top {} -setup $setup1 -body {
try $maketree
set nodecount 0
set counts {}
set res2 [lindex [time {tree1 node walk {} {
upvar counts counts nodecount nodecount
dict incr counts $node
incr nodecount
}} 1] 0]
lappend res {each node once} [::tcl::mathfunc::max {*}[
dict values $counts]]
lappend res {size is correct?} [expr {[tree1 size] == $size1 + $count}]
lappend res {performance is good?} [expr {(double($res2) / $res1 ) < .10}]
return $res
} -cleanup [cleanup1] -result [sl {
{each node once} 1 {size is correct?} 1 {performance is good?} 1
}]
test performance_walk_node {} -setup $setup1 -body {
try $maketree
set node [tree1 node pivot {} 3]
set nodecount 0
set res2 [lindex [time {tree1 node walk $node {
upvar nodecount nodecount
incr nodecount
}} 1] 0]
lappend res {size is correct?} [expr {
[tree1 size] == $size1 + $count
}]
set targetsize [expr {
1
+ 11
+ (11 * 10)
+ (11 * 10 * 9)}
]
lappend res {walk count is correct} [expr {
$nodecount == $targetsize
}]
lappend res {performance is good?} [
expr {(double($res2) / $res1) < .01}]
return $res
} -cleanup [cleanup1] -result [sl {
{size is correct?} 1
{walk count is correct} 1
{performance is good?} 1
}]
}
test performance_pivot_many children -setup $setup1 -body {
set one [tree1 node new {} one]
set two [tree1 node new $one two]
set three [tree1 node new $two three]
set iterations 65536
set name [string repeat abcdefghijlmnopqrstuvwxyz 20]
set db [tree1 .namespace]::db
$db eval {
create table test1 (
node integer primary key
, value unique
)
;create unique index idx_t1 on test1 (
value
)
}
::apply [list {} {
upvar db db elapsed0 elapsed0 name name
upvar iterations iterations
lassign [time {
$db transaction {
for {set i 0} {$i < $iterations} {incr i} {
set value $name$i
$db eval {
insert into test1 values (
null, $value
)
}
}
}
} 1] elapsed0
lassign [time {
$db transaction {
for {set i 0} {$i < $iterations} {incr i} {
set value $name$i
set found [$db eval {
select node from test1 where value = $value
}]
}
}
} 1] perform0a
} [namespace current]]
lassign [time {
tree1 db transaction {
for {set i 0} {$i < $iterations} {incr i} {
tree1 node new $three $name$i
}
}
} 1] elapsed1
set ratio [expr {$elapsed0 / double($elapsed1)}]
lappend res {node creation ratio} $ratio > .5 ? [expr {
$ratio > .5}]
#tree1 db transaction {
# if 0 {
# a left join on tree1link is much slower here
# as it causes a scan
# 3 0 0 {SCAN TABLE tree1tree USING COVERING INDEX tree1tree_idx_value}
# 5 0 0 {SEARCH TABLE tree1values USING INTEGER PRIMARY KEY (rowid=?)}
# therefore
# use a subselect instead
#
# which eliminates the scan
# 3 0 0 {SEARCH TABLE tree1values USING COVERING INDEX sqlite_autoindex_tree1values_1 (value=?)}
# 8 0 0 {SEARCH TABLE tree1tree USING COVERING INDEX tree1tree_idx_value (value=?)}
# 12 0 0 {CORRELATED SCALAR SUBQUERY 1}
# 16 12 0 {SEARCH TABLE tree1link USING INTEGER PRIMARY KEY (rowid=?)}
# }
# set query {
# with recursive
# r (node, value) as (
# select tree1tree.node ,tree1tree.value
# from tree1tree
# join tree1link on tree1link.node = tree1tree.node
# union all
# select tree1tree.node ,tree1tree.value
# from tree1tree join r on tree1tree.node = r.value
# where exists (select node from tree1link where node = r.node )
# )
# select tree1tree.node, tree1values.value
# from tree1tree
# join tree1values on tree1tree.value = tree1values.node
# where (
# tree1values.value = $value and not exists (
# select node from tree1link where tree1link.node = tree1tree.node
# )
# )
# union all
# select r.node ,r.value from r
# join tree1values on r.value = tree1values.node
# where not exists (select node from tree1link where node = r.node)
# }
# lassign [time {
# for {set i 0} {$i < $iterations} {incr i} {
# set value $name$i
# set node [tree1 db eval $query]
# puts [list {looked up value} $node]
# }
# } 1] elapsed1
#}
#set ratio [expr {$elapsed0 / double($elapsed1)}]
#lappend res {table link value join ratio of} $ratio > .5 ? [
# expr {$ratio > .5}]
#lassign [time {
# tree1 db transaction {
# for {set i 0} {$i < $iterations} {incr i} {
# lassign [tree1 node pivot $three $name$i] node
# puts [list {pivoted to} $i]
# }
# }
#} 1] elapsed1
set ratio [expr {$elapsed0 / double($elapsed1)}]
lappend res {node pivot ratio} $ratio > .5 ? [expr {
$ratio> .5}]
set iterations2 [expr {$iterations*2}]
lassign [time {
tree1 db transaction {
for {set i $iterations} {$i < $iterations2} {incr i} {
tree1 node pivot? $three $name$i
#puts [list {attempted pivot to} $i]
}
}
} 1] elapsed1
set ratio [expr {$elapsed0 / double($elapsed1)}]
lappend res {node pivot attempt ratio} $ratio > .5 ? [expr {
$ratio> .5}]
return $res
} -cleanup [cleanup1] -match glob -result [sl {
{node creation ratio} * > .5 ? 1
{node pivot ratio} * > .5 ? 1
{table link value join ratio of} * > .5 ? 1
{node pivot ratio} * > .5 ? 1
{node pivot attempt ratio} * > .5 ? 1
}]
test up_from_top {
moving up from the top node
} -setup $setup1 -body {
lassign [tree1 node new {} {}] node
set up [tree1 node up& $node]
lappend res $up
return $res
} -cleanup [cleanup1] -result [sl {
{}
}]
test value_number {} -setup $setup1 -body {
set res {}
set node [tree1 node new {} 2.3e5]
tree1 node val $node
} -cleanup [cleanup1] -result [sl {
2.3e5
}]
test value_bytes {} -setup $setup1 -body {
set res {}
set data [bytes]
set node [tree1 node new {} $data]
set data2 [tree1 node val $node]
lappend res [expr {$data eq $data2}]
return $res
} -cleanup [cleanup1] -result [sl {
1
}]
test read {} -setup $setup1 -body {
set res {}
tree1 read [startrek]
set count1 0
set vals1 {}
tree1 node walk {} {
upvar count1 count1 res res vals1 vals1
incr count1
lappend vals1 $node
}
set count2 [tree1 db onecolumn {select count(*) as count from tree1tree}]
set vals2 [tree1 db eval {select node from tree1tree}]
foreach val $vals2 {
if {$val ni $vals1} {
puts [list missing $val]
}
}
lappend res [expr {$count1 == $count2}]
set node [tree1 node pivot {} {Star Trek} {}]
# record 118 has a value of 4 and would be a valid link if the node
# value was odd
set children [tree1 node ls $node]
lappend res $children
return $res
} -cleanup [cleanup1] -result [sl {
1
{4 seasons roles}
}]
foreach \
type {spec_missing spec_empty spec_param spec_array} \
spec [list {} [list {}] [list {
level mylevel node mynode up myup ref myref value myvalue}] s] \
levelname {level level mylevel s(level)} \
nodename {node node mynode s(node)} \
up {up up myup s(up)} \
refname {ref ref myref s(ref)} \
valuename {value value myvalue s(value)} \
{
try [string map [list @type@ $type @spec@ $spec @levelname@ \
$levelname @nodename@ $nodename @up@ $up \
@refname@ $refname @valuename@ $valuename] {
test walk_$type {} -setup $setup2 -body {
set res {}
set res2 {}
set count1 0
tree1 node ls& {} {
if {$node == 0} continue
uplevel 1 [list tree1 node walk $node @spec@ {
upvar count1 count1 res2 res2
incr count1
lappend res2 [list $@levelname@ [
tree1 node val $@nodename@] [
tree1 node val $@up@] \
[tree1 value get $@refname@] $@valuename@]
}]
}
lappend res {*}$res2
return $res
} -cleanup [cleanup1] -result [sl {
{0 one one one one}
{1 seven one seven seven}
{0 two two two two}
{0 three three three three}
{1 four three four four}
{1 five three five five}
}]
test walk_break@type@ {
break off the walk
} -setup $setup2 -body {
set res {}
set res2 {}
set count1 0
tree1 node ls& {} {
if {$node == 0} continue
uplevel 1 [list tree1 node walk $node @spec@ {
upvar count1 count1 res2 res2
if {[incr count1] > 3} break
lappend res2 [list $@levelname@ [
tree1 node val $@nodename@] [
tree1 node val $@up@] $@valuename@]
}]
}
lappend res {*}$res2
return $res
} -cleanup [cleanup1] -result [sl {
{0 one one one} {1 seven one seven} {0 two two two}
}]
test walk_node@type@ {} -setup $setup2 -body {
set res {}
set res2 {}
set count1 0
set node [tree1 node pivot {} three]
tree1 node walk $node @spec@ {
upvar count1 count1 res2 res2
incr count1
lappend res2 [list [
tree1 node val $@nodename@] $@levelname@ [
tree1 node val $@up@] $@valuename@]
}
set count2 [tree1 db onecolumn {
select count(*) as count from tree1tree
}]
lappend res [expr {$count1 == $count2}]
lappend res {*}$res2
return $res
} -cleanup [cleanup1] -result [sl {
0 {three 0 three three} {four 1 three four} {five 1 three five}
}]
}]
}
cleanupTests
}