#! /usr/bin/env tclsh
package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl list} {
pop
take
}
{ycl list deep}
{ycl proc} {
optswitch
}
{ycl db sqlite util} {
explain_pretty
idquote
lossless
makereport
minpagesize
}
}
package require {ycl sugar}
namespace import [yclprefix]::sugar::block
namespace import [yclprefix]::sugar::lambda
variable doc {
description
a persistent tree data type
in each tree
node 0
is the system node
where a command takes a node as an argument
the node is a list
where
the first item is a node identifer
any additional items are a list of nodes to pivot to
some commands treat nodes objects
where each subnode is an attribute
the last subnode of the subnode is the value of the attribute
a node
has
a node id
internal use only
may change
track a node by linking to it, not by recording its node id
if node id is ever updated
the system also updates all links
a value
to do
implement some mechanism to express the existence and value of a
node in terms of other nodes
this is similar to XSLT except that with XSLT
document A is applied to document B to produce document C
in the current system system
existing sections of the document are applied to other
sections of the document to produce the content of those
sections
}
::apply [list {} {
set forgevariant iterpivot
### preprocessing start ###
set givenscript {
set arglen [llength $args]
if {$arglen} {
if {$arglen % 2} {
set given {}
set args [lassign $args[set args {}] script]
} else {
set args [lassign $args[set args {}] given script]
}
} else {
set given {}
}
if {[llength $given] > 1} {
try {
dict size $given
} on error {tres topts} {
if {[llength $given] > 1} {
error [list {wrong # args} $given]
}
}
set key $given
} else {
set key {}
}
}
set nodepivot {
if {[llength $node] > 1} {
set node [$_ node pivot {*}$node]
} else {
lassign $node[set node {}] node
}
}
foreach suffix {{} emptyerror} eval {
{
$_ db eval $query
}
{
set res [$_ db eval $query]
if {![llength $res]} {
error [list {no results}]
}
return $res
}
} {
try [string map [list @suffix@ $suffix @eval@ $eval] {
if 0 {
a script evaluation could have arbitrary effects on the database so
it is treated as a transaction
}
set queryscript@suffix@ {
if {[info exists script]} {
if {![info exists qvals]} {
set qvals {}
}
set ns [uplevel 1 {namespace current}]
if {[llength $given] == 1} {
# to do
# add the transaction back when sqlite fixes the
# segmentation fault issue
#
# see https://sqlite.org/forum/forumpost/4638e41470
#$_ db transaction {
tailcall apply [list {_ node query qvals given script} {
$_[unset _] db eval -withoutnulls $query $given $script[
dict with qvals {}]
} $ns] $_ $node $query $qvals $given $script
#}
} else {
#$_ db transaction {
tailcall apply [list {_ node query qvals script} {
$_[unset _] db eval -withoutnulls $query $script[
dict with qvals {}]
} $ns] $_ $node $query $qvals $script
#}
}
} else {
@eval@
}
}
}]
}
### preprocessing end ###
try [string map [list @forgevariant@ $forgevariant @givenscript@ $givenscript \
@nodepivot@ $nodepivot @queryscript@ $queryscript] {
package require sqlite3
package require {ycl cache cache}
namespace import [yclprefix]::cache::cache
package require {ycl string expand}
namespace import [yclprefix]::string::expand
package require {ycl parser interp}
namespace import [yclprefix]::parser::interp::parse
namespace import [yclprefix]::proc::lambda
namespace import [yclprefix]::proc::lambdacurry
package require {ycl db sqlite util}
[yclprefix] proc import dbget [yclprefix]::db::sqlite::util::get
[yclprefix] proc import strquote [yclprefix]::db::sqlite::util::gen::strquote
[yclprefix] proc import table [yclprefix]::db::sqlite::util::table
namespace eval doc::node {}
proc pmap {p1 p2 cache spec argparse body} {
if {$argparse eq {}} {
set argparse {
if {[llength $args]} {
error [list {wrong # args}]
}
}
}
set pmap [string map [list \
@p1@ [list $p1] \
@p2@ [list $p2] \
@cache@ [list $cache] \
@spec@ [list $spec] \
@argparse@ $argparse
] {
@givenscript@
@argparse@
set query [$_ @cache@ get [
list [expr {[llength $node] == 0}] [
expr {[llength $given] == 1}] $key] {
if {[llength $node]} {
set query $@p1@
} else {
set query $@p2@
}
if {[llength $given] == 1} {
string map [makereport @spec@ {}] $query
} else {
string map [makereport @spec@ $given] $query
}
}]
}]
set body "\$_ .vars [list $p1] [list $p2]\n$body"
set body [string map [list @pmap@ $pmap] $body]
return $body
}
proc .init {. _ args} {
variable q_templates
$_ .vars dbitemprefix
set dbitemprefix {}
set dbcreate 1
foreach {opt val} $args {
switch $opt {
dbconn {
if {[info exists dbname]} {
error [list {both db connection and db name were provided}]
}
set dbconn [uplevel 1 [list [namespace which lambdacurry] {*}$val]]
}
dbname {
if {[info exists dbconn]} {
error [list {both db connection and db name were provided}]
}
set dbname $val
}
dbcreate {
set dbcreate $val
}
dbitemprefix {
set dbitemprefix $val
}
default {
error [list {unknown option} $opt]
}
}
}
set myns [$_ .namespace]
foreach name {
alldrothercache
convergecache
convergevaluecache
descendantsrefscache
drothercache
drupothercache
excache
findeq&cache
findglob&cache
findlike&cache
findmatch&cache
findregexp&cache
forgecache
ipath&cache
leavescache
leavesvaluecache
leavesvaluecache
linkscache
lsandcache
lscache
lsemptycache
lsfullcache
lsglob&cache
lslikecache
lslike&cache
lsnext&cache
lsregexp&cache
nodeappearscache
nodrothercache
nodelastcache
nodelast&cache
pathcache
path&cache
pathrefscache
pivotcache
refscache
tailcache
traversecache
walkcache
} {
cache .new ${myns}::$name
$_ .eval [list $_ .routine $name]
$_ $name .init
}
if {[info exist dbconn]} {
uplevel 1 [list $_ .routine db {*}$dbconn]
} else {
if {![info exists dbname]} {
set dbname :memory:
}
set cmd [list sqlite3 [$_ .namespace]::db $dbname]
if {!$dbcreate} {
lappend cmd -create false
}
{*}$cmd
$_ .eval [list $_ .routine db]
}
$_ db cache size 0
try [string map [list @@ $dbitemprefix] $q_templates]
namespace ensemble create -prefixes 0 -command [$_ .namespace]::inode \
-parameters {. _} -map {
path& inode_path&
}
$_ .eval [list $_ .method inode]
namespace ensemble create -prefixes 0 -command [$_ .namespace]::descendants \
-parameters {. _} -map {
refs descendants_refs
referenced? descendants_referenced?
}
$_ .eval [list $_ .method descendants]
namespace ensemble create -prefixes 0 -command [$_ .namespace]::node \
-parameters {. _} -map {
appears& node_appears&
back node_back
back& node_back&
clear node_clear
clone node_clone
converge node_converge
converge& node_converge&
count node_count
cp node_cp
ddict node_ddict
alldr node_alldr
dr node_dr
drcount node_drcount
depth node_depth
dest node_dest
down node_down
down& node_down&
downtoref node_downtoref
edit node_edit
editlink node_editlink
examine node_examine
empty? node_empty?
exists node_exists
findeq& node_findeq&
findglob& node_findglob&
findlike& node_findlike&
findmatch& node_findmatch&
findregexp& node_findregexp&
forge node_forge
id node_id
idgt& node_idgt&
islink node_islink
islost node_islost
last node_last
last& node_last&
leaves node_leaves
leaves& node_leaves&
link node_link
links node_links
linkval node_linkval
ls node_ls
ls& node_ls&
lsglob& node_lsglob&
lslike node_lslike
lslike& node_lslike&
lsempty& node_lsempty&
lsfull& node_lsfull&
lspart& node_lspart&
lsregexp& node_lsregexp&
move node_move
new node_new
next& node_next&
forth node_forth
forth& node_forth&
highestid node_highestid
nodr node_nodr
path node_path
path& node_path&
pivot node_pivot
pivot? node_pivot?
pretty node_pretty
read_deep node_readdeep
referenced? node_referenced?
refs node_refs
repoint node_repoint
rm node_rm
rm? node_rm?
pathrefs node_pathrefs
set node_set
setd node_setd
target node_target
traverse node_traverse
tree node_tree
tail& node_tail&
under node_under
up node_up
up& node_up&
val node_val
valueid node_valueid
walk node_walk
}
$_ .eval [list $_ .method node]
namespace ensemble create -prefixes 0 -command [$_ .namespace]::value \
-parameters {. _} -map {
get value_get
}
$_ .eval [list $_ .method value]
namespace ensemble create -prefixes 0 -command [$_ .namespace]::values \
-parameters {. _} -map {
count values_count
}
$_ .eval [list $_ .method values]
$_ setupdb
return $_
}
.my .method .init
proc accelerate {} {
try {
package require critcl
} on error {tres topts} {
puts stderr [list [namespace current] \
[dict get $topts -errorinfo]
]
return 0
}
critcl cproc [namespace current]::node_forge_c {Tcl_Interp* interp object __ object _ char* up list path} object {
Tcl_Obj *res;
res = Tcl_NewListObj(0 ,NULL);
Tcl_ListObjAppendElement(interp ,res ,Tcl_NewObj());
Tcl_ListObjAppendElement(interp ,res ,Tcl_NewIntObj(1));
Tcl_IncrRefCount(res);
return res;
}
.my .method node_forge_c
try {
critcl load
} on error {tres topts} {
puts stderr [list [namespace current] \
{could not accelerate} [dict get $topts -errorinfo]
]
return 0
}
return 1
}
proc checkvalue {. _ node value {depth 0}} {
$_ .vars q_check_value q_node_link_node
if {$depth > 4096} {
return [list {} 1]
}
$_ db eval $q_node_link_node {
tailcall $_ checkvalue $ref $value [incr depth]
}
list [$_ db onecolumn $q_check_value] 0
}
.my .method checkvalue
proc db_createsysinfo {. _} {
variable magicb
$_ .vars sysnode
lassign [$_ node forge {} .] sysnode
$_ node set $sysnode magic $magicb
$_ node forge $sysnode version major 0
$_ node forge $sysnode version minor 1
$_ node forge $sysnode version patch 0
return
}
.my .method db_createsysinfo
proc dbitemprefix {. _} {
$_ .vars dbitemprefix
return $dbitemprefix
}
.my .method dbitemprefix
variable doc::descendants_refs {
description {
finds all nodes that reference a descendant of the given node
}
}
proc descendants_refs {. _ node args} {
$_ .vars q_refs_descendants
@nodepivot@
@givenscript@
set query [$_ descendantsrefscache get $key {
string map [makereport node $given] $q_refs_descendants
}]
@queryscript@
}
.my .method descendants_refs
variable doc::descendants_refs? {
description {
returns true if there are any references to any descendant nodes
}
}
proc descendants_referenced? {. _ node args} {
$_ .vars q_refs_descendants?
@nodepivot@
$_ db exists ${q_refs_descendants?}
}
.my .method descendants_referenced?
proc inode_path& {. _ node args} {
$_ .vars q_node_path_node
@givenscript@
set query [$_ ipath&cache get $key {
string map [makereport node $given] $q_node_path_node
}]
@queryscript@
}
.my .method inode_path&
proc node_clear {. _ args} {
$_ .vars q_tree_delete_node_children q_tree_delete_node_top
set node $args
@nodepivot@
if {[llength $node]} {
$_ db eval $q_tree_delete_node_children
} else {
$_ db eval $q_tree_delete_node_top
}
return
}
.my .method node_clear
proc node_converge {. _ node other args} {
$_ .vars q_node_converge_value
@nodepivot@
@givenscript@
set query [$_ convergevaluecache get $key {
string map [makereport value $given] $q_node_converge_value
}]
@queryscript@
}
.my .method node_converge
proc node_converge& {. _ node other args} {
$_ .vars q_node_converge
@nodepivot@
@givenscript@
set query [$_ convergecache get $key {
string map [makereport node $given] $q_node_converge
}]
@queryscript@
}
.my .method node_converge
variable doc::node_cp {
description {
create a copy of a node and place it in another node
if a copied link references a node that is also copied during this operation
the link is adjusted to point to the new copy of the referenced node
}
}
proc node_cp {. _ node to} {
$_ .vars s_node_cp
@nodepivot@
if {[llength $to]} {
set to [$_ node pivot {*}$to]
} else {
lassign $to[set node {}] to
}
if {![llength $to]} {
set to [$_ node new {} {}]
}
if {[llength $node]} {
# to do
# this is poorly tested
#
# particularly the calculation of new "up" and "link" values
$_ db transaction {
$_ db eval $s_node_cp
}
} else {
error [list finish this]
# {to do} finish this
}
return
}
.my .method node_cp
proc lost {. _ args} {
$_ .vars q_lost
$_ db eval $q_lost {
set lambda [uplevel 1 [
list [namespace which lambda] node {*}$args $node]]
uplevel 1 $lambda
}
}
.my .method lost
proc node_appears& {. _ node other args} {
$_ .vars q_node_appears
@nodepivot@
@givenscript@
set query [$_ nodeappearscache get $key {
string map [makereport {node level indirects} $given] $q_node_appears
}]
dict set qvals other $other
@queryscript@
}
.my .method node_appears&
if 0 {
# didn't work because incrblob can't write channels of arbitrary size
proc node_chan {. _} {
$_ .vars dbitemprefix sql_link_delete sql_readchan_tmptable
$_ db eval $sql_link_delete
set id [$_ db onecolumn $sql_readchan_tmptable]
set chan [$_ db incrblob ${dbitemprefix}readchan_value value $id]
list $id $chan
}
.my .method node_chan
proc node_close {. _ node name id chan newnode} {
$_ .vars sql_readchan_insert sql_readchan_delete sql_readchan_queryvalues
#close $chan
@nodepivot@
set res [$_ db onecolumn $sql_readchan_queryvalues]
if {$res ne {}} {
try {
$_ db onecolumn $sql_readchan_insert
} finally {
$_ db eval $sql_readchan_delete
}
} else {
$db eval $sql_readchan_delete
}
return $newnode
}
.my .method node_close
}
proc node_clone {. _ node} {
$_ db transaction {
if 0 {
to do
write tests for this
}
set up [$_ node up& $node]
set new [$_ node new $up]
set target [$_ node target $node]
if {$target eq {}} {
$_ node val $new [$_ node val $node]
} else {
$_ node editlink $new $target
}
}
return $new
}
.my .method node_clone
variable doc::node_all {
description {
deep references in a node or any link to it
}
}
proc node_alldr {. _ node other in args} {
$_ .vars q_alldr_other
@nodepivot@
@givenscript@
set query [$_ alldrothercache get $key {
string map [makereport {node up} $given] $q_alldr_other
}]
lappend qvals in $in other $other
@queryscript@
}
.my .method node_alldr
variable doc::node_dr {
description {
deep references
}
}
proc node_dr {. _ node other args} {
$_ .vars q_dr_other
@nodepivot@
@givenscript@
set query [$_ drothercache get $key {
string map [makereport {node up} $given] $q_dr_other
}]
lappend qvals other $other
@queryscript@
}
.my .method node_dr
variable doc::node_dr {
description {
deep references
}
}
proc node_drcount {. _ node other} {
$_ .vars q_dr_other_count
@nodepivot@
$_ db onecolumn $q_dr_other_count
}
.my .method node_drcount
proc node_depth {. _ node} {
llength [$_ node path $node]]
}
.my .method node_depth
variable doc::node_ddict {
description {
produce a deep list from a given node
}
}
proc node_ddict {. _ node} {
set res {}
set lastlevel 0
lappend isdict 0
set myisdict 0
set path {}
$_ node walk $node {
upvar indices indices isdict isdict lastlevel lastlevel \
myisdict myisdict path path res res
if {$level != $lastlevel} {
if {$level > $lastlevel} {
set oldpath $path
lappend path end
# this is $mydict from the old level
if {!$myisdict} {
#convert to dictionary
set d1 $res
deep node d1 {*}$oldpath
set d1 [concat {*}[lmap item $d1 {
list $item {}
}]]
lset isdict $lastlevel 1
lset res {*}$oldpath $d1
#deep insert res $path {}
}
lappend isdict 0
} elseif {$level < $lastlevel} {
if {![lindex $isdict $lastlevel]} {
# quote level as a list of terminal node values
set d1 $res
deep node d1 {*}$path
# [deep set] takes adds the needed quoting, so no need for
# this
#set d1 [list $d1[set d1 {}]]
deep set res {*}$path $d1
}
set isdict [lrange $isdict[set isdict {}] 0 $level]
set path [lreplace $path[set path {}] end-[
expr {$lastlevel - $level -1}] end]
}
set myisdict [lindex $isdict $level]
}
set newpath $path
lappend newpath end
if {$myisdict} {
deep insert res $newpath $value {}
} else {
deep insert res $newpath $value
}
set lastlevel $level
}
return $res
}
.my .method node_ddict
variable doc::node_dest {
description
return the targets of a link
or the empty string if the node is not a link
}
proc node_dest {. _ node args} {
$_ .vars q_node_dest
@nodepivot@
$_ db onecolumn $q_node_dest
}
.my .method node_dest
proc node_down {. _ node} {
@nodepivot@
$_ node val [$_ node down& $node]
}
.my .method node_down
proc node_down& {. _ node} {
$_ .vars q_down&
$_ db eval ${q_down&}
}
.my .method node_down&
proc node_downtoref {. _ node ref args} {
$_ .vars q_downtoref
while {[llength $args]} {
take args arg
optswitch $arg {
allowed {
take args allowed
}
}
}
set res [$_ db eval $q_downtoref]
if {[info exists allowed]} {
if {[llength $res] > $allowed} {
error [list {too many results} allowed $allowed count [
llength $res]]
}
}
return $res
}
.my .method node_down&
proc node_edit {. _ node value} {$_ db transaction {
$_ .vars q_node_edit
# strip any internal representation off $value to keep sqlite types
# consistent
# in particular
# make sure that something like 0xfa that happens to have a numeric
# internal representation is not converted to 250
# to do: what is the performance cost of this?
# to do: isn't this unneeded since the advent of [lossless]?
set value [string range $value[set value {}] 0 end]
$_ db transaction {
$_ db eval $q_node_edit
}
return
}}
.my .method node_edit
proc node_editlink {. _ node reference} {$_ db transaction {
$_ .vars q_tree_editlink
$_ db eval $q_tree_editlink
}}
.my .method node_editlink
proc node_examine {. _ node args} [pmap \
{} \
q_tree_examine_top \
excache \
{node up value nodetype uptype valuetype ref reftype} {} {
@nodepivot@
@pmap@
@queryscript@
}
]
.my .method node_examine
proc node_empty? {. _ node args} {
$_ .vars q_node_empty q_top_empty
@nodepivot@
if {[llength $node]} {
$_ db onecolumn $q_node_empty
} else {
$_ db onecolumn $q_top_empty
}
}
.my .method node_empty?
proc node_exists {. _ args} {
expr {[$_ node pivot? {*}$args] != {}}
}
.my .method node_exists
proc node_highestid {. _} {
$_ .vars q_node_highest
$_ db onecolumn $q_node_highest
}
.my .method node_highestid
proc node_mustexist {. _ node} {
if {![$_ node exists $node]} {
error [list {no such node} $node]
}
}
.my .method node_mustexist
proc node_findeq& {. _ node value args} [pmap \
q_treevalseq_any_node \
q_treevalseq_any_top \
findeq&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals value $value
@queryscript@
}]
.my .method node_findeq&
proc node_findglob& {. _ node value args} [pmap \
q_treevalsglob_any_node \
q_treevalsglob_any_top_node \
findglob&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals value $value
@queryscript@
}]
.my .method node_findglob&
proc node_findlike& {. _ node value args} [pmap \
q_treevalslike_any_node \
q_treevalslike_any_top_node \
findlike&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals value $value
@queryscript@
}]
.my .method node_findlike&
proc node_findmatch& {. _ node value args} [pmap \
q_treevalsmatch_any_node \
q_treevalsmatch_any_top_node \
findmatch&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals value $value
@queryscript@
}]
.my .method node_findmatch&
proc node_findregexp& {. _ node value args} [pmap \
q_treevalsregexp_any_node \
q_treevalsregexp_any_top_node \
findregexp&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals value $value
@queryscript@
}]
.my .method node_findregexp&
switch @forgevariant@ {
sqltmptable {
proc node_forge {. _ node args} {
#$_ node_forge_c up args
$_ .vars q_node_forge_up_node_0 q_node_forge_up_node_2 \
q_node_forge_up_node_1 q_node_forge_up_top
set created 0
@nodepivot@
$_ db transaction {
if {[llength $args]} {
if {$node eq {}} {
take args value
set query $q_node_forge_up_top
set node [$_ db eval $query]
if {$node eq {}} {
set node [$_ node new {} $value]
incr created
}
}
set i 0
foreach value $args {
set value_$i $value
incr i
}
set query [$_ forgecache get [llength $args] {
set i 0
set query $q_node_forge_up_node_0
foreach value $args {
append query [subst -nobackslashes -novariables [
string map [
list @value@ \$value_$i] $q_node_forge_up_node_1]]
incr i
}
append query $q_node_forge_up_node_2
}]
lassign [$_ db eval $query] node created2
incr created $created2
}
}
return [list $node $created]
}
.my .method node_forge
}
iterpivot {
proc node_forge {. _ node args} {
$_ .vars q_tree_select_node
#$_ node_forge_c up args
set created 0
$_ db transaction {
@nodepivot@
if {[llength $args]} {
if {$node eq {}} {
take args arg
set new [$_ node pivot? $node $arg]
if {$new eq {}} {
set node [$_ node new {} $arg]
incr created
} else {
set node $new
}
} else {
if {![llength [$_ db onecolumn $q_tree_select_node]]} {
error [list {no such node} $node]
}
}
foreach arg $args {
set new [$_ node pivot? $node $arg]
if {$new eq {}} {
set node [$_ node new $node $arg]
incr created
} else {
set node $new
}
}
}
}
return [list $node $created]
}
.my .method node_forge
}
sqlpivot {
proc node_forge {. _ node args} {
#$_ node_forge_c up args
$_ .vars q_node_forge_up_node q_node_forge_up_top
set created 0
@nodepivot@
$_ db transaction {
if {[llength $args]} {
if {$node eq {}} {
take args value
set query $q_node_forge_up_top
set node [$_ db eval $query]
if {$node eq {}} {
set node [$_ node new {} $value]
incr created
}
}
foreach value $args {
set query $q_node_forge_up_node
lassign [$_ db eval $query] new
if {$new eq {}} {
set node [$_ node new $node $value]
incr created
} else {
set node $new
}
}
}
}
return [list $node $created]
}
.my .method node_forge
}
}
proc node_forth {. _ node args} {
$_ .vars q_node_forth
@nodepivot@
set pivot [$_ node_forth& {*}$node $args]
if {$pivot ne {}} {
return [$_ node val $pivot]
}
error [list {no node forth} node $node]
}
.my .method node_forth
variable doc::node_forth& {
description {
return the node next node forth
or the empty string if this is the last node
}
}
proc node_forth& {. _ node args} {
if 0 {
to do
test top and intermediate cases
}
$_ .vars q_node_forth
if {[llength $args]} {
set node [$_ node_pivot? $node {*}$args]
}
set res [$_ db onecolumn $q_node_forth]
return $res
}
.my .method node_forth&
proc node_id {. _ node new} {
$_ .vars q_node_id
@nodepivot@
$_ node_mustexist $node
$_ db onecolumn $q_node_id
}
.my .method node_id
proc node_idgt& {. _ node val} {
$_ .vars q_node_idgt_up_node
@nodepivot@
set res [$_ db onecolumn $q_node_idgt_up_node]
}
.my .method node_idgt&
proc node_islink {. _ node} {
$_ .vars q_node_link
$_ db exists $q_node_link
}
.my .method node_islink
proc node_islost {. _ node} {
$_ .vars q_islost
@nodepivot@
$_ node_mustexist $node
expr {[llength [$_ db eval $q_islost]] != 0}
}
.my .method node_islost
variable doc::node_last {
returns the value of the last child of some node
}
proc node_last {. _ args} {
set node $args
$_ .vars q_node_last_root_value q_node_last_node_value
@nodepivot@
@givenscript@
set query [$_ nodelastcache get [list $node $key] {
if {[llength $node]} {
set query $q_node_last_node_value
} else {
set query $q_node_last_root_value
}
lindex $query
}]
set res [$_ db eval $query]
if {![llength $res]} {
error [list {no results}]
}
return [lindex $res 0]
}
.my .method node_last
variable doc::node_last& {
returns the id of last child of some node
}
proc node_last& {. _ args} {
set node $args
$_ .vars q_node_last_node_node q_node_last_root_node
@nodepivot@
@givenscript@
set query [$_ nodelast&cache get [list $node $key] {
if {[llength $node]} {
set query $q_node_last_node_node
} else {
set query $q_node_last_root_node
}
lindex $query
}]
set res [$_ db eval $query]
if {![llength $res]} {
error [list {no results}]
}
return [lindex $res 0]
}
.my .method node_last&
if 0 {
to do
add the ability to select breadth-first instead of depth-first
}
proc node_leaves {. _ node args} {
$_ .vars q_node_leavesvalue
@nodepivot@
@givenscript@
set query [$_ leavesvaluecache get $key {
string map [makereport value $given] $q_node_leavesvalue
}]
@queryscript@
}
.my .method node_leaves&
proc node_leaves& {. _ node args} {
$_ .vars q_node_leaves
@nodepivot@
@givenscript@
set query [$_ leavescache get $key {
string map [makereport node $given] $q_node_leaves
}]
@queryscript@
}
.my .method node_leaves&
proc node_link {. _ node args} {
$_ .vars q_tree_select_node \
q_tree_insert_link_top \
q_tree_insert_link \
q_tree_forth
@nodepivot@
foreach ref $args {
$_ db transaction {
if {![$_ node_exists $ref]} {
error [list {no such node}]
}
set new [$_ db onecolumn $q_tree_forth]
if {$node eq {}} {
$_ db eval $q_tree_insert_link_top
} else {
if {![$_ db exists $q_tree_select_node]} {
error [list {no such up} $node]
}
$_ db eval $q_tree_insert_link
}
}
}
return $new
}
variable doc::links {
returns all direct links links to a node
}
proc node_links {. _ node args} {
$_ .vars q_node_links
@nodepivot@
@givenscript@
set query [$_ linkscache get $key {
string map [makereport node $given] $q_node_links
}]
@queryscript@
}
.my .method node_links
proc node_linkval {. _ node args} {
$_ .vars q_node_linkval_set
@nodepivot@
if {[llength $args] == 1} {
lassign $args ref
$_ db eval $q_node_linkval_set
} elseif {[llength $args]} {
error [list {wrong # args} [llength $args]]
}
$_ node val $node
}
.my .method node_linkval
variable doc::node_ls {
description
lists the values of nodes one step down
nodes with no values are omitted
if a script is provided
then
foreach resulting value
evaluates the script is its own local scope
if a name specification is provided
then
otherwise
the following variables are available
value
the value of the node
otherwise
returns the resulting list of values
}
proc node_ls {. _ node args} [pmap \
q_treevals_value_up_node \
q_treevals_up_top_value \
lscache \
value {} {
@nodepivot@
@pmap@
@queryscript@
}]
.my .method node_ls
variable doc::node::ls& {
description {
lists all nodes one step down
if a script is provided
then
for each resulting node
evaluates the script in its own local scope
under the level of the caller of ls&
variables available in the evaluation level are
node
the resulting node
currently
the local scope the script is evaluated in contains some
variables used to set up the evaluation, and also any row
variables created by sqlite itself
this makes the evaluation environment a little
confusing
this situation should be improved
otherwise
returns a list of resulting nodes
}
}
proc node_ls& {. _ node args} [pmap \
q_treevals_node_up_node \
q_treevals_up_top_node \
lsandcache \
node {} {
@nodepivot@
@pmap@
@queryscript@
}]
.my .method node_ls&
proc node_lsempty& {. _ node args} [pmap \
q_node_lsempty \
q_node_lsempty_top \
lsemptycache \
node {} {
@nodepivot@
@pmap@
@queryscript@
}]
.my .method node_lsempty&
proc node_lsglob& {. _ node value args} [pmap \
q_treevalsglob_node_up_node \
q_treevalsglob_up_top_node \
lsglob&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals value $value
@queryscript@
}]
.my .method node_lsglob&
proc node_lsfull& {. _ node args} [pmap \
q_node_lsfull \
q_node_lsfull_top \
lsfullcache \
node {} {
@nodepivot@
@pmap@
@queryscript@
}]
.my .method node_lsfull&
proc node_lslike {. _ node like args} [pmap \
q_treevalslike_value_up_node \
q_treevalslike_up_top_value \
lslikecache \
value {} {
@nodepivot@
@pmap@
lappend qvals like $like
@queryscript@
}]
.my .method node_lslike
proc node_lspart& {. _ node offset limit args} [pmap \
q_treevalspart_node_up_node \
q_treevalspart_up_top_node \
lsandcache \
node {} {
@nodepivot@
@pmap@
lappend qvals offset $offset limit $limit
@queryscript@
}]
.my .method node_lspart&
if 0 {
to do
require sqlite icu extension for uniformity?
}
proc node_lslike& {. _ node value args} [pmap \
q_treevalslike_node_up_node \
q_treevalslike_up_top_node \
lslike&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals value $value
@queryscript@
}]
.my .method node_lslike&
proc node_lsregexp& {. _ node value args} [pmap \
q_treevalsregexp_node_up_node \
q_treevalslike_up_top_node \
lsregexp&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals value $value
@queryscript@
}]
.my .method node_lsregexp&
proc node_move {. _ node to} {
$_ .vars s_move_to
set path [$_ inode_path& $to]
if {$node in [$_ inode_path& $to]} {
if 0 {
to do
this guard needs some tests
}
error [list {can not move a node into its descendants}]
}
$_ db eval $s_move_to
return
}
.my .method move
variable doc::new {
variable description {
foreach $arg in $args
insert into the specified existing node one new variable with a
value of $arg
}
}
proc node_new {. _ args} {
$_ .vars q_tree_insert_value q_insert_values_value \
q_node_new_value_exists \
q_tree_forth \
q_tree_select_node \
q_select_values_node_from_value q_tree_insert_value_top
if {[llength $args]} {
take args node
} else {
set node {}
}
@nodepivot@
if {![llength $args]} {
lappend args {}
}
if 0 {
to do
can foreach be moved into the transaction?
}
if 0 {
to do
have this routine return the first created node
}
foreach value $args {
$_ db transaction {
if {![$_ db exists $q_node_new_value_exists]} {
$_ db eval $q_insert_values_value
}
lassign [$_ db eval $q_select_values_node_from_value] \
ref value2 valuetype
#if {$ref eq {} || $value2 ne $value} {
# error [list {value would be corrupted in database}]
#}
set new [$_ db onecolumn $q_tree_forth]
if {$node eq {}} {
$_ db eval $q_tree_insert_value_top
} else {
#if {![$_ db exists $q_tree_select_node]} {
# error [list {no such up} $node]
#}
$_ db eval $q_tree_insert_value
}
}
}
return $new
}
.my .method node_new
proc node_next& {. _ node offset limit args} [pmap \
q_treenodenext_node_up_node \
q_treenodenext_up_top_node \
lsnext&cache \
node {} {
@nodepivot@
@pmap@
lappend qvals limit $limit offset $offset
@queryscript@
}]
.my .method node_next&
variable doc::node_nodr {
description {
finds nodes in one tree that are not referenced in another
}
}
proc node_nodr {. _ node other args} {
$_ .vars q_nodr_other
@nodepivot@
@givenscript@
set query [$_ nodrothercache get $key {
string map [makereport node $given] $q_nodr_other
}]
lappend qvals other $other
@queryscript@
}
.my .method node_nodr
proc node_path {. _ node args} {
$_ .vars q_node_path_value
@nodepivot@
@givenscript@
set query [$_ pathcache get $key {
string map [makereport value $given] $q_node_path_value
}]
@queryscript@
}
.my .method node_path
proc node_path& {. _ node args} {
$_ .vars q_node_path_node
@nodepivot@
@givenscript@
set query [$_ path&cache get $key {
string map [makereport node $given] $q_node_path_node
}]
@queryscript@
}
.my .method node_path&
proc node_pivot {. _ node args} {
set res [$_ node_pivot? $node {*}$args]
if {![llength $res]} {
error [list {no such path} node $node path $args]
}
lindex $res 0
}
.my .method node_pivot
switch 2 {
0 {
proc node_pivot? {. _ node args} {
lassign [$_ node_pivot_query $node {*}$args] params query
dict with params {}
set res [$_ db eval $query]
if {[llength $res]} {
return [lindex $res end]
}
return {}
}
.my .method node_pivot?
}
1 {
proc node_pivot? {. _ node args} {
$_ .vars q_pivot_name q_node q_pivot_name_top
$_ db transaction {
if {$node eq {}} {
take args value
set node [$_ db onecolumn $q_pivot_name_top]
set res $node
}
foreach value $args {
set node [$_ db onecolumn $q_pivot_name]
set res $node
}
if {![info exists res]} {
set res [$_ db onecolumn $q_node]
}
}
return $res
}
.my .method node_pivot?
}
2 {
proc node_pivot? {. _ node args} {
$_ .vars q_check_value q_node q_node_link_top q_node_link_target \
q_pivot_simple q_pivot_name_simple q_pivot_top_simple q_valueid
$_ db transaction {
if {$node eq {}} {
take args value
set new [$_ db onecolumn $q_pivot_top_simple]
if {$new eq {}} {
set found {}
$_ db eval $q_node_link_top {
lassign [$_ checkvalue $target $value] checked toodeep
if {$checked ne {}} {
set found $node
}
}
if {$found eq {}} {
return {}
} else {
set node $found
}
} else {
set node $new
}
set res $node
} else {
set arg_up $node
}
foreach value $args {
set new [$_ db onecolumn $q_pivot_name_simple]
#set valueid [$_ db onecolumn $q_valueid]
#if {$valueid eq {}} {
# set new {}
#} else {
# set new [$_ db onecolumn $q_pivot_simple]
#}
if {$new eq {}} {
set found {}
# find the last matching node
# to do: find all matching nodes?
$_ db eval $q_node_link_target {
lassign [$_ checkvalue $target $value] checked toodeep
if {$checked ne {}} {
set found $node
}
}
if {$found eq {}} {
set node {}
} else {
set node $found
}
} else {
set node $new
}
set res $node
}
if {![info exists res]} {
set res [$_ db onecolumn $q_node]
}
}
return $res
}
.my .method node_pivot?
}
}
# this was too slow, and ran into sql stack and reference limits
# slowness is possibly due to the cyclic link at the top level in the test
# suite
# {to do} diagnose and optimize
proc node_pivot_query {. _ node args} {
$_ .vars dbitemprefix q_pivot_roots \
q_pivot_node q_pivot_subquery q_with
if {[llength $args]} {
set key [list [expr {[llength $node] == 0}] [llength $args]]
set i 0
if {[$_ pivotcache exists $key]} {
set query [$_ pivotcache get $key]
foreach arg $args {
dict set params arg_$i $arg
incr i
}
} else {
set query {with recursive}
if {$node eq {}} {
take args arg
dict set params arg_$i $arg
set haverx 1
set excludetop {}
append query [string map [
list r1 rl$i @where@ "
where ${dbitemprefix}tree.node = ${dbitemprefix}tree.up
" @joins@ {} @recurse@ {}] $q_with]
append query "
, rx$i\(node) as (
select node from r$i where
case
when cast(cast(\$arg_$i as numeric) as text) = cast(\$arg_$i as text)
then cast(\$arg_$i as numeric)
when cast(\$arg_$i as text) = \$arg_$i
then cast(\$arg_$i as text)
else cast(\$arg_$i as blob)
end
=
case when r$i.value is null
then (
select value from rl$i
where rl$i.orignode = r$i.node
and rl$i.value is not null
)
else r$i.value
end
)
"
} else {
set excludetop \
"and ${dbitemprefix}tree.up != ${dbitemprefix}tree.node"
append query [string map [
list r1 rl$i @where@ "
where ${dbitemprefix}tree.node = \$node
" @joins@ {} @recurse@ {}] $q_with]
set haverx 0
}
set ip $i
incr i
foreach arg $args {
dict set params arg_$i $arg
if {$haverx} {
set rx rx
} else {
set rx r
}
append query "
,[string map [
list r0 r$i r1 rl$i @where@ {} @joins@ "
join $rx$ip on $rx$ip.node = ${dbitemprefix}tree.up
$excludetop
" @recurse@ {}] $q_with
]
, rx$i\(node) as (
select node from r$i where
case
when cast(cast(\$arg_$i as numeric) as text) = cast(\$arg_$i as text)
then cast(\$arg_$i as numeric)
when cast(\$arg_$i as text) = \$arg_$i
then cast(\$arg_$i as text)
else cast(\$arg_$i as blob)
end
=
case when r$i.value is null
then (
select value from rl$i
where rl$i.orignode = r$i.node
and rl$i.value is not null
)
else r$i.value
end
)
"
set haverx 1
set excludetop \
"and ${dbitemprefix}tree.up != ${dbitemprefix}tree.node"
set ip $i
incr i
# debugging
if 0 {
::apply [list {_ params query} {
puts stderr [list debug node_pivot_query]
puts stderr $params
puts stderr $query
dict with params {}
foreach key [dict keys $params] {
puts stderr [list $key [set $key]]
}
puts stderr [list [$_ db eval $query]]
puts stderr [$_ db eval {select * from tree1values}]
} [namespace current]] $_ $params $query
}
}
incr i -1
if {$haverx} {
append query "
select node from rx$i
"
} else {
append query "
select node from r$i
"
}
$_ pivotcache set $key $query
}
return [list $params $query]
} else {
if {$node == {}} {
return [list {} $q_pivot_roots]
} else {
dict set params arg_0 $node
return [list $params $q_pivot_node]
}
}
}
.my .method node_pivot_query
proc node_pretty {. _ node args} {
$_ .vars dbitemprefix
if 0 {
to do
if $chan is the empty string
set up a channel
produce output to that channel
read the contents of the channel
destroy the channel
return the contens of the channel
}
set chan stdout
set simple 0
while {[llength $args]} {
set args [lassign $args[set args {}] arg val]
switch $arg {
chan {
set chan $val
}
simple {
set simple 1
}
default {
error [list {unknown option} $arg]
}
}
}
if {$simple} {
set report {[string repeat \t $level] [list $value]}
} else {
set report {[string repeat \t $level] [list $node] [list $up] [
list $ref] [list $value]}
}
$_ node walk $node {
upvar report report
upvar chan chan
puts $chan [subst $report]
}
return
}
.my .method node_pretty
proc node_back {. _ node args} {
$_ .vars q_node_back
set pivot [$_ node back& $node {*}$args]
if {$pivot ne {}} {
return [$_ node val $pivot]
}
error [list {no back node} node $node]
}
.my .method node_back
variable doc::node_back& {
description {
return the back node
or the empty string if this is the first node
}
}
proc node_back& {. _ node args} {
$_ .vars q_node_back
if {[llength $args]} {
set node [$_ node_pivot? $node {*}$args]
}
$_ db onecolumn $q_node_back
}
.my .method node_back&
proc node_readdeep {. _ node data} {
foreach {key val} $data[set data {}] {
lassign [$_ node forge $node $key] new
if {[llength $val] == 1} {
foreach item [lindex $val[set val {}] 0] {
$_ node forge $new $item
}
} else {
$_ node read_deep $new $val[set val {}]
}
}
return
}
.my .method node_readdeep
variable doc::refs {
returns all direct and indirect links to a node
}
proc node_refs {. _ node args} {
$_ .vars q_node_refs
@nodepivot@
@givenscript@
set query [$_ refscache get $key {
string map [makereport {node up} $given] $q_node_refs
}]
@queryscript@
}
.my .method node_refs
proc node_referenced? {. _ node} {
$_ .vars q_node_refs?
@nodepivot@
$_ db exists ${q_node_refs?}
}
proc node_repoint {. _ node target} {
$_ .vars sql_repoint
@nodepivot@
if {![$_ node islink $node]} {
error [list {not a link}]
}
$_ db eval $sql_repoint
return
}
.my .method node_repoint
proc node_rm {. _ node args} {
$_ .vars s_delete_node
set node [list $node[
set node {}] {*}$args[set args {}]]
@nodepivot@
if {[$_ node referenced? $node] || [$_ descendants referenced? $node]} {
error [
list {there are references to the node or its descendants } $node]
}
$_ node ls& $node {
upvar _ _
$_ node_rm $node
}
$_ db eval $s_delete_node
return
}
.my .method node_rm
proc node_pathrefs {. _ node to args} [pmap \
q_node_up_pathrefs \
q_treevals_up_top_pathrefs \
pathrefscache \
node {} {
@nodepivot@
@pmap@
lappend qvals to $to
@queryscript@
}
]
.my .method node_pathrefs
variable doc::node_set {
description
modify the value of an attribute of $node
add a new attribute if there is no attribute by the given name
args
node
the node to operate on
args
0 to last-2
pivot
last-1
the name of the attribute
if a name is not provided
the node is considered to be the attribute node itself
rather than the object node
last
the value of the attribute
}
proc node_set {. _ node args} {
if {[llength $args] == 2} {
pop args name val
} elseif {[llength $args] == 1} {
pop args val
}
if {[llength $args]} {
set node [list {*}$node {*}$args]
}
@nodepivot@
if {[info exists name]} {
set namenode [$_ node_pivot? $node $name]
if {$namenode eq {}} {
set namenode [$_ node new $node $name]
}
} else {
set namenode $node
}
$_ node clear $namenode
$_ node new $namenode $val
}
.my .method node_set
proc node_setd {. _ node args} {
foreach {key val} $args {
$_ node set $node $key $val
}
return
}
.my .method node_setd
proc node_count {. _ node} {
$_ .vars q_node_count q_top_count
if {[llength $node]} {
$_ db onecolumn $q_node_count
} else {
$_ db onecolumn $q_top_count
}
}
.my .method node_count
variable doc::node_target {
description
return the targets of a link
or the empty string if the node is not a link
}
proc node_target {. _ node args} {
$_ .vars q_node_link
@nodepivot@
$_ db eval $q_node_link
}
.my .method node_target
variable doc::node::traverse {
description
visit every node from the top of the tree to the specified node
}
proc node_traverse {. _ node args} {
@nodepivot@
$_ .vars q_node_traverse
@givenscript@
set query [$_ traversecache get $key {
string map [makereport {node up ref value level} $given] $q_node_traverse
}]
@queryscript@
}
.my .method node_traverse
proc node_tail& {. _ node limit args} [pmap \
q_treevals_node_up_node_tail \
q_treevals_up_top_node_tail \
tailcache \
node {} {
@nodepivot@
@pmap@
lappend qvals limit $limit
@queryscript@
}]
.my .method node_tail&
proc node_tree {. _ node args} {
if {[llength $args] == 1} {
set tree [lindex $args[set args {}] 0]
} else {
set tree $args[set args {}]
}
if {[llength $tree] == 0 || [llength $tree] % 2} {
error [list {wrong # args}]
}
foreach {key values} $tree {
set newnode [$_ node new $node $key]
if {![info exists res]} {
set res $newnode
}
if {[llength $values] == 1} {
$_ node new $newnode [lindex $values 0]
} else {
if {[llength $values]} {
$_ node tree $newnode $values
}
}
}
return
}
.my .method node_tree
proc node_under {. _ node other} {
$_ .vars q_node_under
@nodepivot@
$_ db onecolumn $q_node_under
}
.my .method node_under
proc node_up {. _ node} {
@nodepivot@
$_ node val [$_ node up& $node]
}
.my .method node_up
proc node_up& {. _ node} {
$_ .vars q_up&
$_ db eval ${q_up&}
}
.my .method node_up&
variable doc::node_val {
description
get or set the value of a node
}
proc node_val {. _ node args} {
@nodepivot@
$_ .vars q_node_val q_node_val_set
if {[llength $args] == 1} {
lassign $args value
$_ db eval $q_node_val_set
} elseif {[llength $args]} {
error [list {wrong # args} [llength $args]]
}
dbget [list $_ db] $q_node_val
}
.my .method node_val
variable doc::node_valueid {
description
returns the id of the value for the node
useful for fast comparisons
}
proc node_valueid {. _ node} {
$_ .vars q_node_valueid
$_ db onecolumn $q_node_valueid
}
.my .method node_val
proc node_walk {. _ node args} [pmap \
q_walk_node \
q_walk_root \
walkcache \
{node up ref value level} {} {
@nodepivot@
@pmap@
@queryscript@
}]
.my .method node_walk
proc ondeleted {. _ node up value} {
}
.my .method ondeleted
proc oninserted {. _ node up value} {
}
.my .method oninserted
proc onupdated {. _ onode oup ovalue nnode nup nvalue} {
}
.my .method onupdated
proc read {. _ data} {
$_ .vars sql_create_table_readmap sql_delete_table_readmap \
sql_insert_table_readmap sql_select_table_readmap \
sql_select_tree_forth sql_table_tree_readmap
set count 0
$_ db transaction {
$_ db eval $sql_create_table_readmap
parse $data ::apply [list {_ args} {
upvar count count map map \
sql_insert_table_readmap sql_insert_table_readmap
incr count
$_ .vars s_insert_value s_insert_link
if {[llength $args] == 0} {
error [list {this is impossible}]
} elseif {[llength $args] == 1} {
set node [lindex $args 0]
set up $node
catch {unset value}
} elseif {[llength $args] == 2} {
lassign $args node up
catch {unset value}
} elseif {[llength $args] == 3} {
lassign $args node up value
} else {
error [list {too many arguments} record $count $args]
}
# make sure we've got two numbers
try {expr {$node + 0}} on error {tres topts} {
error [list {node is not a number} $count $args]
}
try {expr {$up + 0}} on error {tres topts} {
error [list {up is not a number} $count $args]
}
# NULL values are not allowed in the tree
if {![info exists value]} {
set value {}
}
if {$node % 2} {
set value [expr {$value + 0}]
set new [$_ db eval $s_insert_link]
} else {
set new [$_ db eval $s_insert_value]
}
$_ db eval $sql_insert_table_readmap
} [namespace current]] $_
$_ db eval $sql_table_tree_readmap
#$_ db eval $sql_select_table_readmap {
# puts [list readmap $old $new]
#}
$_ db eval $sql_delete_table_readmap
}
return
}
.my .method read
proc setupdb {. _} {
variable magicb
$_ .vars dbitemprefix q_dbsetup q_dbsetup_query q_dbsetup_insert \
q_dbsetup_values_exist sysnode
$_ db transaction {
$_ db function ${dbitemprefix}ondeleted [list $_ ondeleted]
$_ db function ${dbitemprefix}oninserted [list $_ oninserted]
$_ db function ${dbitemprefix}onupdated [list $_ onupdated]
}
if {
[table exists [list $_ db] ${dbitemprefix}tree]
||
[table exists [list $_ db] ${dbitemprefix}values]
} {
set valid 0
if {[table exists [list $_ db] ${dbitemprefix}values]} {
if {
[$_ node exists {} . magic]
&& [$_ node last {} . magic] == $magicb
} {
set valid 1
} elseif {[$_ db exists $q_dbsetup_query]} {
# {to do} {delete this part after all old trees have been
# converted}
#convert this old tree into a newer one
$_ db_createsysinfo
set valid 1
}
}
if {$valid} {
set sysnode [$_ node pivot {} .]
} else {
error [list {not a valid tree}]
}
} else {
minpagesize [list $_ db] 8192
$_ db eval {
pragma encoding = "utf-8"
; pragma cache_size = 10000
}
$_ db transaction {
$_ db eval $q_dbsetup
if {![$_ db exists $q_dbsetup_values_exist]} {
$_ db eval $q_dbsetup_insert
}
$_ db_createsysinfo
}
}
}
.my .method setupdb
proc size {. _} {
$_ .vars q_size
$_ db onecolumn $q_size
}
.my .method size
proc tree_roots {. _} {
$_ db eval {select * from tree where node = up}
}
.my .method tree_roots
proc value_get {. _ id} {
$_ .vars sql_value_get
$_ db onecolumn $sql_value_get
}
.my .method value_get
proc values_count {. _} {
$_ .vars sql_values_count
$_ db onecolumn $sql_values_count
}
.my .method value_count
.my .routine util
variable magic 46d4dc3c35caf20ebb4df605730cda0652a99990592c20e87043001f3cb589ff
variable magicb [binary format H* $magic]
::apply [list {} {
variable q_templates
proc t_query_compare {where op recurse} {
return [subst -nobackslash -novariables [string map [
list @op@ $op @recurse@ [list $recurse]] {
[t_with r0 r1 @@tree $where @recurse@]
select node as @name0@ from ([t_with_select_nonames r0 r1])
where value @op@ $value
order by node
}]]
}
proc t_query_compare_node {op recurse} {
t_query_compare {where @@tree.up = $node and @@tree.node != @@tree.up} $op $recurse
}
proc t_query_compare_top {op recurse} {
t_query_compare {where @@tree.node = @@tree.up} $op $recurse
}
proc t_query_resolvelink {t where} {
string map [list @t@ $t @where@ $where] {
@t@(orignode ,up ,node ,ref ,level) as (
select
@@tree.node
,@@tree.up
,@@tree.node
,@@tree.value
,0
from @@tree
where @@tree.node in (select node from @@link)
@where@
union all
select @t@.orignode ,@t@.up ,@@tree.node ,@@tree.value ,level+1
from @@tree join @t@ on @@tree.node = @t@.ref
and @t@.node in (select node from @@link)
and level < 512
)
}
}
proc t_r {where op value} {
if {$value ne {}} {
set value "and \"@@values\".value $op $value"
}
if {$where ne {}} {
set where1 "and $where"
} else {
set where1 $where
}
string map [list @r@ [t_query_resolvelink r $where1] @where@ $where @value@ $value] {
@r@
select @@tree.node,@@tree.up ,null ,null ,"@@values".value
from @@tree
join "@@values" on @@tree.value = "@@values".node
where
@where@
and (
not exists (
select node from @@link where @@link.node = @@tree.node
)
@value@
)
union all
select r.orignode ,@@tree.up ,null ,null ,"@@values".value
from @@tree join r on @@tree.node = r.node
join "@@values" on r.ref = "@@values".node
and r.node not in (select node from @@link)
@value@
order by @@tree.node
}
}
proc t_treevalquery {select where op value limit null} {
if {$null} {
set nullconstraint {}
} else {
set nullconstraint {where value is not null}
}
list [subst -nobackslash -novariables [string map [
list @select@ $select @limit@ $limit \
@nullconstraint@ $nullconstraint] {
select @select@ from (
with recursive
[t_r $where $op $value]
)
@nullconstraint@
@limit@
}]]
}
proc t_with {r0 r1 tree where recurse args} {
string map [list @where@ $where @recurse@ $recurse] [
t_with_raw $tree $r0 $r1 {*}$args]
}
proc t_with_raw {tree r0 r1 args} {
# be careful when changing this. It has been carefully tuned to hurdle
# performance landmines.
# left joins are avoided even though it doesn't seem they were a
# performance concern
set tables {}
while {[llength $args]} {
take args arg
switch $arg {
table {
take args table
append tables " ,$table"
}
default {
error [list {unknown option} $arg]
}
}
}
string map [list @r0@ $r0 @r1@ $r1 @tables@ $tables @tree@ $tree] {
@r0@(node ,up ,link ,ref ,value ,level, top) as (
select @tree@.node
,@tree@.up
, case when
@tree@.node in (select node from @@link)
then @tree@.node
else null
end
,@tree@.value
,
case when @tree@.node in (select node from @@link)
then null
else (
select value from "@@values"
where @tree@.value = "@@values".node
)
end
,0
,@tree@.node
from @tree@ @tables@
@where@
@recurse@
)
,
@r1@(orignode ,up ,level ,link ,origref ,finalnode ,ref ,value ,indirects, top) as (
select node ,up ,level ,link ,ref ,node ,ref ,value ,0, top
from @r0@
union all
select
@r1@.orignode
, @r1@.up
, level
, case when
t2.node in (select node from @@link)
then t2.node
else null
end
, origref
, t2.node
, t2.value
, case when t2.node in (select node from @@link)
then null
else (
select value from "@@values"
where t2.value = "@@values".node
)
end
,@r1@.indirects+1
,@r1@.top
from @tree@ as t2 join @r1@ on @r1@.ref = t2.node and indirects < 512
where @r1@.link is not null
)
}
}
proc t_with_value {} {
string map [list @r@ [t_query_resolvelink r {}]] {
(node ,value ,level) as (
with recursive
@r@
select @@tree.node ,"@@values".value ,level
from @@tree join r on @@tree.node == r.orignode join "@@values" on r.ref = "@@values".node
where not exists (
select node from @@link where @@link.node = r.node
)
union all
select @@tree.node ,"@@values".value ,0
from @@tree join "@@values"
on @@tree.value = "@@values".node
where @@tree.node not in (select node from @@link)
order by @@tree.node
)
}
}
proc t_recurse_base {r0 join} {
if {$join ne {}} {
set join "on $join"
}
string map [list @r0@ $r0 @join@ $join] {
union all
select
@@tree.node
, @@tree.up
, case when
@@tree.node in (select node from @@link)
then @@tree.node
else null
end
, @@tree.value
, case when @@tree.node in (select node from @@link)
then null
else (
select value from "@@values"
where @@tree.value = "@@values".node
)
end
, level + 1
, @r0@.top
from @@tree
join @r0@ @join@
order by 6 desc, 1
}
}
proc t_recurse r0 {
t_recurse_base $r0 [string map [list @r0@ $r0] {
@@tree.up = @r0@.node and @@tree.node != @@tree.up
}]
}
proc t_recurse_up table {
t_recurse_base $table [string map [list @table@ $table] {
@@tree.node = @table@.up and @table@.node != @table@.up
}]
}
apply [list {} {
set template {
@t@(node ,up) as (
select @@tree.node ,@@tree.up from @@tree @tables@
where @@tree.@field@ @where@ and @@tree.node in (
select node from @@link
)
union all
select @t@2.node ,@t@2.up from @@tree as @t@2 ,@t@
where value = @t@.node and @t@2.node in (
select node from @@link
)
)
}
foreach field {
value
node
} {
set template2 [string map [list @field@ $field] $template]
proc t_with_refs_where_$field {tablename where args} [
string map [list @template@ [list $template2]] {
set tables {}
while {[llength $args]} {
take args arg
switch $arg {
table {
take args table
append tables ", [idquote $table]"
}
default {
error [list {unknown options}]
}
}
}
string map [list @t@ $tablename @tables@ \
$tables @where@ $where] @template@
}]
}
} [namespace current]]
proc t_subtree {tree where} {
set res [string map [list @tree@ $tree @where@ $where ] {
(node, up ,value) as (
select node ,up ,value from @tree@
@where@
union all
select @tree@.node ,@tree@.up ,@tree@.value
from @tree@, t0
where @tree@.up = t0.node
and @tree@.node != @tree@.up
)
}]
return $res
}
proc t_with_path {tablename nodevar} {
string map [list @nodevar@ $nodevar @tablename@ $tablename] {
@tablename@(node ,up ,level) as (
select node ,up ,0 from @@tree where @@tree.node = $@nodevar@
union all
select @@tree.node ,@@tree.up ,@tablename@.level+1
from @@tree join @tablename@ on @@tree.node = @tablename@.up
and @@tree.node != @tablename@.node
)
}
}
proc t_with_select {r0 r1} {
string map [list @r0@ $r0 @r1@ $r1] {
select
@r0@.node as @name0@
, @r0@.up as @name1@
, @r0@.link
, @r0@.ref as @name2@
, case when link is null
then @r0@.value
else (
select value from @r1@
where @r0@.node = @r1@.orignode
and @r1@.link is null
)
end as @name3@
,@r0@.level as @name4@
,@r0@.top
from @r0@
}
}
proc t_with_select_raw r0 {
string map [list @r0@ $r0] {
select
@r0@.node as @name0@
, @r0@.up as @name1@
, @r0@.link
, @r0@.ref as @name2@
, @r0@.value
,@r0@.level as @name4@
,@r0@.top
from @r0@
}
}
proc t_with_select_nonames {r0 r1} {
string map {@name0@ node @name1@ up @name2@ ref @name3@ value
@name4@ level} [t_with_select $r0 $r1]
}
proc t_with_select_raw_nonames r0 {
string map {@name0@ node @name1@ up @name2@ ref @name3@ value
@name4@ level} [t_with_select_raw $r0]
}
set q_templates [subst -nobackslash -novariables {
$_ $ q_with [list [string map {@recurse@ {}} [t_with_raw @@tree r0 r1]]]
$_ $ q_dbsetup_values_exist {select 1 from "@@values"}
$_ $ q_dbsetup {
-- autoincrement is needed in because insertion order is used in
-- ordered operations, e.g. to sort nodes or determine last and first
-- child
create table if not exists @@forge (
node integer primary key
, changes
, created integer
)
; create table if not exists @@link (
node integer primary key
)
; create unique index if not exists @@link_idx_unique on @@link (
node
)
-- the not null constraint was added on {2020 01 22}
-- and tests were changed accordingly
-- I strongly suspect that not allowing NULL is the right design
; create table if not exists @@tree (
node integer primary key autoincrement
, up integer
, value integer NOT NULL
)
; create index if not exists @@tree_idx_up on @@tree (
up
)
; create index if not exists @@tree_idx_value on @@tree (
value
)
; create trigger if not exists @@trigger_tree_inserted after
insert on @@tree
begin
select @@oninserted(NEW.node ,NEW.up ,NEW.value)
; end
; create trigger if not exists @@trigger_tree_deleted after
delete on @@tree
begin
select @@ondeleted(OLD.node ,OLD.up ,OLD.value)
; end
; create trigger if not exists @@trigger_value_updated after
update on @@tree
begin
select @@onupdated(OLD.node ,OLD.up ,OLD.value
, NEW.node ,NEW.up ,NEW.value)
; end
; create table if not exists "@@values" (
node integer primary key
-- no affinity declaration so that sql scripts can cast as needed
, value unique
)
}
$_ $ q_dbsetup_insert {
insert into "@@values" values (null ,'')
; insert into "@@values" values (null ,[lossless \$magicb])
}
$_ $ q_dbsetup_query {
select 1 from "@@values" where node = 2 and value = [lossless \$magicb]
}
$_ $ q_down& {
select node from @@tree where up = $node and node != $node
order by node asc limit 1
}
switch 0 {
0 {
# this is 27x faster than the
# and node in (select ...)
# variant
$_ $ q_downtoref {
select node from @@tree where up = $node and value = $ref
and exists (
select node from @@link
where @@link.node = @@tree.node
)
order by node asc limit 1
}
}
1 {
# this is 27x faster than the
# and node in (select node from @@link)
# subselect version
$_ $ q_downtoref {
select @@tree.node from @@tree join @@link on @@tree.node = @@link.node
where up = $node and value = $ref
and @@link.node is not NULL
order by @@tree.node asc limit 1
}
}
2 {
$_ $ q_downtoref {
select node from @@tree where up = $node and value = $ref
and node in (select node from @@link)
order by node asc limit 1
}
}
}
$_ $ q_lost {
select node from @@tree where not exists (
select 1 from @@tree as tree2 where tree2.node = @@tree.up
)
}
$_ $ q_islost {
select node from @@tree
where node = $node
and not exists (
select 1 from @@tree as tree2 where tree2.node = @@tree.up
)
}
$_ $ q_node_appears {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
select orignode as @name0@
,r1.level as @name1@
,r1.indirects as @name2@
from r1 where r1.ref = $other
order by r1.level
}
$_ $ q_node_converge {
with recursive
[t_with_path t1 node]
, [t_with_path t2 other]
select node as @name0@ from t1
where node not in (
select node from t2
)
order by level desc
}
$_ $ q_node_converge_value {
with recursive
[t_with_path t1 node]
, [t_with_path t2 other]
, t3[t_with_value]
select (select value from t3 where t3.node = t1a.node ) as @name0@ from t1 as t1a
where not exists (
select node from t2 where t2.node = t1a.node
)
order by level desc
}
$_ $ q_node_dest {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} {}]
select finalnode from r1 where link is null and finalnode != $node
}
$_ $ q_node_up_pathrefs {
with recursive
[t_with_path t1 to]
, [t_with r2 r3 @@tree {where @@tree.node = $node} [t_recurse r2]]
select r3.orignode as @name0@ from r3 join t1 where r3.ref = t1.node
}
$_ $ q_node_edit {
insert or ignore into "@@values" values (null ,[lossless \$value])
; update @@tree set value = (
select node from 'values' where value = [lossless \$value])
where node = $node
; delete from @@link where node = $node
}
switch 1 {
0 {
$_ $ q_node_id {
update @@tree set node = $new where node = $node
; update @@tree set value = $new
where node in (
select node from @@link
) and value = $node
}
}
1 {
$_ $ q_node_id {
update @@tree set node = $new where node = $node
; update @@tree set value = $new
where exists (
select node from @@link
where @@link.node = @@tree.node
) and value = $node
}
}
}
$_ $ q_node_idgt_up_node {
select @@tree.node
from @@tree
where @@tree.up = $node and @@tree.node > $val
order by @@tree.node limit 1
}
#$_ $ q_node_link {
# select @@tree.value as ref
# from @@tree join @@link on @@tree.node = @@link.node
# where @@tree.up = $node
#}
# this subselect variant is two orders of magnitude faster than a join
# on @@link
switch 1 {
0 {
$_ $ q_node_link {
select @@tree.value as ref
from @@tree
where @@tree.node = $node
and @@tree.node in (select node from @@link)
}
}
1 {
$_ $ q_node_link {
select @@tree.value as ref
from @@tree
where @@tree.node = $node
and exists (
select node from @@link where node = @@tree.node
)
}
}
}
#$_ $ q_node_link_top {
# select @@tree.node ,@@tree.value as target
# from @@tree join @@link on @@tree.node = @@link.node
# where @@tree.node = @@tree.up
#}
# this subselect variant is two orders of magnitudefaster than a join
# on @@link
switch 1 {
0 {
$_ $ q_node_link_top {
select @@tree.node ,@@tree.value as target
from @@tree
where @@tree.node = @@tree.up and @@tree.node in (
select node from @@link
)
}
}
1 {
$_ $ q_node_link_top {
select @@tree.node ,@@tree.value as target
from @@tree
where @@tree.node = @@tree.up
and exists (
select node from @@link where node = @@tree.node
)
}
}
}
#$_ $ q_node_link_node {
# select @@tree.value as ref
# from @@tree join @@link on @@tree.node = @@link.node
# where @@tree.node = $node
#}
# this subselect variant is two orders of magnitude faster than a join on @@link
switch 0 {
0 {
$_ $ q_node_link_node {
select @@tree.value as ref
from @@tree
where @@tree.node = $node
and exists (
select node from @@link where node = @@tree.node
)
}
}
1 {
$_ $ q_node_link_node {
select @@tree.value as ref
from @@tree
where @@tree.node = $node
and @@tree.node in (select node from @@link)
}
}
}
switch 0 {
0 {
# this subselect variant is two orders of magnitue faster than
# a join on @@link
$_ $ q_node_link_target {
select @@tree.node ,@@tree.value as target
from @@tree
where @@tree.up = $node
and @@tree.node in (select node from @@link)
}
}
1 {
# this subselect is much slower than the
# @@tree.node in (select)
# variant
$_ $ q_node_link_target {
select @@tree.node ,@@tree.value as target
from @@tree
where @@tree.up = $node
and exists (
select 1 from @@link where node = @@tree.node
limit 1
)
}
}
2 {
$_ $ q_node_link_target {
select @@tree.node ,@@tree.value as target
from @@tree
left join @@link on @@tree.node = @@link.node
where @@tree.up = $node
and @@link.node is not null
}
}
}
switch 0 {
0 {
$_ $ q_node_links {
select node from @@tree where node in (
select node from @@link
) and value = $node
}
}
1 {
# this is orders of magnitude slower than the
# node in (select ...)
# variant
$_ $ q_node_links {
select node from @@tree where
exists (
select node from @@link where node = @@tree.node
) and value = $node
}
}
}
$_ $ q_node_refs {
with recursive [t_with_refs_where_value t1 {= $node}]
select node as @name0@ ,up as @name1@ from t1
}
$_ $ q_refs_descendants {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
,[t_with_refs_where_value t1 {in (select node from r0)}]
select node as @name0@ from t1
}
switch 2 {
0 {
$_ $ q_alldr_other {
with recursive
t0[t_subtree @@tree {where node = $in}]
, [t_with r0 r1 t0 {where t0.node = $other} [t_recurse r0]]
, [t_with_refs_where_value t1 {in (select node from r0)}]
, [t_with r2 r3 @@tree {where @@tree.node = t1.node} [t_recurse r2] \
table t1]
select orignode as @name0@, up as @name1@ from r3 where ref = $node
}
}
1 {
$_ $ q_alldr_other {
with recursive
t0[t_subtree @@tree {where node = $in}]
, [t_with_refs_where_value t1 { = $node}]
, [t_with t2 t3 t0 {where t0.node = t1.node} [t_recurse_up t2] table t1]
select t3.top as @name0@, (
select up from @@tree where node = t3.top
) as @name1@
from t3
where t3.ref = $other
}
}
2 {
$_ $ q_alldr_other {
with recursive
t0[t_subtree @@tree {where node = $in}]
, [t_with_refs_where_value t1 { = $node}]
, [t_with t2 t3 t0 {where t0.node = t1.node} [t_recurse_up t2] table t1]
select t1.node as @name0@, t1.up as @name1@ from t1
where exists (
select 1 from t3
where t3.top = t1.node
and t3.ref = $other
limit 1
)
}
}
}
$_ $ q_dr_other {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
,[t_with_refs_where_value t1 {in (select node from r0)}]
, [t_with r2 r3 @@tree {where @@tree.node = $other} [t_recurse r2]]
select node as @name0@ ,up as @name1@ from t1 where node in (
select orignode from r3
)
}
$_ $ q_dr_other_count {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
,[t_with_refs_where_value t1 {in (select node from r0)}]
, [t_with r2 r3 @@tree {where @@tree.node = $other} [t_recurse r2]]
select count(node) from t1 where node in (
select orignode from r3
)
}
$_ $ q_nodr_other {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
,[t_with_refs_where_value t1 {in (select node from r0)}]
, [t_with r2 r3 @@tree {where @@tree.node = $other} [t_recurse r2]]
select orignode as @name0@ from r1 where not exists (
select orignode from r3 where orignode = r1.orignode
)
}
$_ $ q_refs_descendants? {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
,[t_with_refs_where_value t1 {= $node}]
select 1 from t1 limit 1
}
$_ $ q_node_refs? {
with recursive [t_with_refs_where_value t1 {= $node}]
select 1 from t1 limit 1
}
$_ $ q_size {
select count(*) from @@tree
}
$_ $ q_node_last_root_node {
select node from @@tree where up = node
order by node desc
limit 1
}
switch @forgevariant@ {
sqltmptable {
$_ $ q_node_forge_up_node_0 {
; delete from @@forge
; insert into @@forge values (
$node, 0 ,0
)
}
$_ $ q_node_forge_up_node_1 {
; insert or ignore into "@@values" values (
null ,[lossless @value@]
)
; update @@forge set changes = total_changes() + 1
; insert into @@tree select
coalesce(( select max(node) + 1 from @@tree ), 0)
, (select node from @@forge)
, (select node from "@@values" where value = [lossless @value@])
where not exists (
[join [t_treevalquery {
node
} {
@@tree.up = (select node from @@forge)
and @@tree.up != @@tree.node
} = [lossless @value@] {
order by node desc
limit 1
} 0]]
)
; update @@forge set created = created + 1
where changes != total_changes()
; update @@forge set node = (
[join [t_treevalquery {
node
} {
@@tree.up = (select node from @@forge)
and @@tree.up != @@tree.node
} = [lossless @value@] {
order by node desc
limit 1
} 0]]
)
}
$_ $ q_node_forge_up_node_2 {
; select node, created from @@forge
}
}
iterpivot - sqlpivot {
$_ $ q_node_forge_up_node [t_treevalquery {
node
} {
@@tree.up = $node and @@tree.up != @@tree.node
} = [lossless \$value] {
limit 1
} 0]
}
}
$_ $ q_node_forge_up_top [t_treevalquery {
node as node
} {
@@tree.node = @@tree.up
} = [lossless \$value] {
limit 1
} 0]
$_ $ q_node_last_node_node {
select node from @@tree
where up = $node and @@tree.node != @@tree.up
order by node desc
limit 1
}
$_ $ q_node_last_node_value [t_treevalquery {
value
} {
@@tree.up = $node and @@tree.up != @@tree.node
} {} {} {
order by node desc limit 1
} 1]
$_ $ q_node_last_root_value [t_treevalquery {
value
} {
@@tree.node = @@tree.up
} {} {} {
order by node desc
limit 1
} 1]
$_ $ q_node_leaves {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
, r2(node ,up ,link ,ref ,value ,level, top) as (
select * from r0 where not exists (
select 1 from @@tree t2 where t2.up = r0.node
)
)
select node as @name0@ from ([t_with_select_nonames r2 r1])
}
$_ $ q_node_leavesvalue {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
, r2(node ,up ,link ,ref ,value ,level, top) as (
select * from r0 where not exists (
select 1 from @@tree t2 where t2.up = r0.node
)
)
, t3[t_with_value]
select (select value from t3 where t3.node = r2.node ) as @name0@ from r2
-- select case when r2.link is null then r2.value else t3.value end
-- as @name0@ from r2 join t3 on r2.ref = t3.node
-- order by r2.level desc
}
$_ $ q_node_count {
select count(*) from @@tree where up = $node and node != $node
}
$_ $ q_top_count {
select count(*) from @@tree where node = up
}
$_ $ q_node_highest {
select max(node) from @@tree
}
$_ $ q_treenodenext_node_up_node {
select node as @name0@ from @@tree where up = (
select up from @@tree where node = $node
) and node > $node
order by node
limit $limit offset $offset
}
$_ $ q_treevals_up_top_node {
select node as @name0@ from @@tree where up = node
}
$_ $ q_treevalspart_up_top_node {
select node as @name0@ from @@tree where up = node
order by node
limit $limit offset $offset
}
$_ $ q_treevalslike_up_top_node {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse_up r0]]
select orignode as @name0@ from r1 where up = node
and value like $value
}
$_ $ q_treevals_up_top_value [t_treevalquery {
value as @name0@
} {
@@tree.node = @@tree.up
} {} {} {} 1]
$_ $ q_node_path_node {
with recursive
[t_with_path t1 node]
select node as @name0@ from t1
order by level desc
}
$_ $ q_node_path_value {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse_up r0]]
select value as @name0@ from ([t_with_select_nonames r0 r1])
order by level desc
}
$_ $ q_node_forth {
select node from @@tree where not exists (
select * from @@tree where node = $node and up = node
) and up = (
select up from @@tree where node = $node
) and node > $node
union
select node from @@tree where node = up and node > $node
order by node limit 1
}
$_ $ q_insert_values_value {
insert into "@@values" values (null ,[lossless \$value])
}
$_ $ q_node_new_value_exists {
select 1 from "@@values" where value = [lossless \$value]
}
$_ $ q_node_back {
select node from @@tree where up = (
select up from @@tree where node = $node
) and node < $node
order by node desc limit 1
}
$_ $ q_node_traverse {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
select node as @name0@
,up as @name1@
,ref as @name2@
,value as @name3@
,level as @name4@
from ([t_with_select_nonames r0 r1])
}
$_ $ q_node {
select node from @@tree where node = $node
}
$_ $ q_node_empty {
select count(node) == 0 from @@tree
where up = $node and node != $node
limit 1
}
$_ $ q_top_empty {
select count(node) == 0 from @@tree
where node = up
limit 1
}
$_ $ q_node_lsempty {
with
t1(node) as (
select node as @name0@ from @@tree where up = $node
and node != up
order by node
)
select node from t1 where not exists (
select 1 from @@tree where up = t1.node
)
}
$_ $ q_node_lsfull {
with
t1(node) as (
select node as @name0@ from @@tree where up = $node
and node != up
order by node
)
select node from t1 where exists (
select 1 from @@tree where up = t1.node
)
}
$_ $ q_node_under {
with recursive
t1 (node ,level) as (
select up , 1 as level from @@tree
where node = $node
and up != $node
union all
select up, level + 1 as level from @@tree, t1
where @@tree.node = t1.node
and @@tree.node != @@tree.up
)
select level from t1 where node = $other
}
if 0 {
$_ $ q_node_val {
with
[t_with r0 r1 @@tree {where @@tree.node = $node} {}]
select value from ([t_with_select_nonames r0 r1])
where value is not null
}
} else {
$_ $ q_node_val [t_treevalquery {
value
} {
@@tree.node = $node
} {} {} {} 0]
}
$_ $ q_node_valueid {
with recursive
[t_query_resolvelink r { and @@tree.node = $node }]
select value from @@tree where node = $node and node not in (
select node from @@link
)
union all
select ref from r
where not exists (
select node from @@link where @@link.node = r.node
)
}
$_ $ q_node_linkval_set {
; insert or ignore into @@link values (
$node
)
; update @@tree set value = $ref where node = $node
}
$_ $ q_node_val_set {
insert or ignore into "@@values" values (null ,[lossless \$value])
; update @@tree set value = (
select node from "@@values" where value = [lossless \$value]
) where node = $node
}
$_ $ q_up& {
select up from @@tree where node = $node and up != node
order by node desc limit 1
}
switch k {
0 {
# this is much faster when pivoting to nodes that already exist
# but no faster when searching for a node that doesn't.
$_ $ q_pivot_name {
with
[t_with r0 r1 @@tree [subst -nobackslashes -novariables {
where @@tree.up = $node
and @@tree.node != @@tree.up
and (
(
@@link.node is null
and
"@@values".value = [lossless \$value]
)
or (
@@link.node is not null
)
)
}] {}]
select node from ([t_with_select_nonames r0 r1])
where value = [lossless \$value]
order by node desc limit 1
}
}
1 {
# to do
# isn't this incomplete in the link case?
$_ $ q_pivot_name {
; select @@tree.node
from @@tree , "@@values"
where @@tree.up = $node
and @@tree.node != @@tree.up
and (
(
@@tree.node not in (select node from @@link)
and
@@tree.value = "@@values".node
and
"@@values".value = [lossless \$value]
)
or (
@@tree.node in (select node from @@link)
and (
)
)
)
order by @@tree.node desc limit 1
}
}
2 {
$_ $ q_pivot_name [t_treevalquery {
node
} {
@@tree.up = $node and @@tree.up != @@tree.node
} = [lossless \$value] {
order by node desc limit 1
} 1]
}
}
$_ $ q_pivot_simple {
select @@tree.node from @@tree
where @@tree.up = $node
and @@tree.up != @@tree.node
and @@tree.value = $valueid
and @@tree.node not in (select node from @@link)
order by @@tree.node desc limit 1
}
if 0 {
$_ $ q_pivot_name_simple {
select @@tree.node from @@tree
where @@tree.up = $node
and @@tree.up != @@tree.node
and @@tree.node not in (select node from @@link)
and [lossless \$value] = (
select value from "@@values" where "@@values".node = @@tree.value
)
}
}
# This query is faster than the subselect version
$_ $ q_pivot_name_simple {
select @@tree.node from @@tree
join "@@values" on @@tree.value = "@@values".node
where @@tree.up = $node
and @@tree.up != @@tree.node
and @@tree.node not in (select node from @@link)
and [lossless \$value] = "@@values".value
}
# This query has been measured to be about 20% faster than the same
# query reworded to use "join"
$_ $ q_check_value {
select @@tree.node from @@tree
where @@tree.node = $node
and [lossless \$value] = (
select value from "@@values" where "@@values".node = @@tree.value
)
order by @@tree.node desc limit 1
}
$_ $ q_valueid {
select node from "@@values" where value = [lossless \$value]
}
# no significant performance difference between these variants
switch 0 {
0 {
$_ $ q_pivot_top_simple {
select @@tree.node from @@tree
where @@tree.up = @@tree.node
and @@tree.node not in (select node from @@link)
and [lossless \$value] in (
select value from "@@values" where "@@values".node = @@tree.value
)
}
}
1 {
$_ $ q_pivot_top_simple {
select @@tree.node from @@tree
left join @@link on @@tree.node = @@link.node
where @@tree.up = @@tree.node
and @@link.node is null
and [lossless \$value] in (
select value from "@@values" where "@@values".node = @@tree.value
)
}
}
2 {
$_ $ q_pivot_top_simple {
select @@tree.node from @@tree
join "@@values" on @@tree.value = "@@values".node
left join @@link on @@tree.node = @@link.node
where @@tree.up = @@tree.node
and @@link.node is null
and [lossless \$value] = "@@values".value
}
}
}
$_ $ q_pivot_subquery {
with
[t_with r0 r1 @@tree {where @@tree.up = ( @subquery@ )} {}]
select node from ([t_with_select_nonames r0 r1]) where value = @value@
order by node desc
}
$_ $ q_pivot_name_top {
with
[t_with r0 r1 @@tree [subst -nobackslashes -novariables {
where @@tree.up = @@tree.node
and (
(
@@link.node is null
and
"@@values".value = [lossless \$value]
)
or (
@@link.node is not null
)
)
}] {}]
select node from ([t_with_select_nonames r0 r1])
where value = [lossless \$value]
order by node desc limit 1
}
$_ $ q_pivot_node {
select node from @@tree where node = $arg_0
order by node desc limit 1
}
$_ $ q_pivot_roots {
select node from @@tree where up = node
order by node limit 1
}
$_ $ q_select_values_node_from_value {
select node , value , typeof(value) from "@@values"
where value = [lossless \$value]
}
$_ $ q_tree_delete_node_top {
delete from @@tree where up = $node and node = $node
}
$_ $ q_tree_delete_node_children {
delete from @@tree where up = $node and node != $node
}
$_ $ q_tree_insert_link_top {
-- do this first to avoid using last_insert_rowid,
-- which might be affected by triggers
insert into @@link values (
(select max(node) + 1 from @@tree)
)
; insert into @@tree values (
(select max(node) + 1 from @@tree)
, (select max(node) + 1 from @@tree)
, $ref
)
}
$_ $ q_tree_insert_link {
-- do this first to avoid using last_insert_rowid,
-- which might be affected by triggers
insert into @@link values (
(select max(node) + 1 from @@tree)
)
; insert into @@tree values (
(select max(node) + 1 from @@tree)
, $node ,$ref
)
}
$_ $ q_tree_editlink {
update @@tree set value = cast($reference as numeric)
where node = $node
; insert or ignore into @@link values (
$node
)
}
$_ $ q_tree_insert_value {
insert into @@tree values (
(select max(node) + 1 from @@tree)
,$node ,$ref
)
}
$_ $ q_tree_insert_value_top {
insert into @@tree values (
coalesce(( select max(node) + 1 from @@tree ), 0)
, coalesce(( select max(node) + 1 from @@tree ), 0)
,$ref
)
}
$_ $ q_tree_forth {
select coalesce(( select max(node) + 1 from @@tree ), 0)
}
$_ $ q_tree_select_node {
select 1 from @@tree where node = $node
}
$_ $ q_treevals_node_up_node {
select node as @name0@ from @@tree where up = $node
and node != up
order by node
}
$_ $ q_treevalspart_node_up_node {
select node as @name0@ from @@tree where up = $node
and node != up
order by node limit $limit offset $offset
}
$_ $ q_treevalsglob_any_node {
with
[t_query_compare_node glob [t_recurse r0]]
}
$_ $ q_treevalseq_any_node {
with
[t_query_compare_node = [t_recurse r0]]
}
$_ $ q_treevalseq_any_top {
with
[t_query_compare_top = [t_recurse r0]]
}
$_ $ q_treevalslike_any_node {
with
[t_query_compare_node like [t_recurse r0]]
}
$_ $ q_treevalsmatch_any_node {
with
[t_query_compare_node match [t_recurse r0]]
}
$_ $ q_treevalsregexp_any_node {
with
[t_query_compare_node regexp [t_recurse r0]]
}
$_ $ q_treevalsmatch_any_node {
with
[t_query_compare_node match [t_recurse r0]]
}
$_ $ q_treevalsglob_node_up_node {
with
[t_query_compare_node glob {}]
}
$_ $ q_treevalslike_node_up_node {
with
[t_query_compare_node like {}]
}
$_ $ q_treevalsregexp_node_up_node {
with
[t_query_compare_node regexp {}]
}
$_ $ q_treevals_node_up_node_tail {
with t1(node) as (
select node from @@tree where up = $node
and node != up
order by node desc limit $limit
)
select node as @name0@ from t1 order by node
}
$_ $ q_treevals_value_up_node {
with
[t_with r0 r1 @@tree {where @@tree.up = $node and @@tree.node != @@tree.up} {}]
select value as @name0@ from ([t_with_select_nonames r0 r1])
order by node
}
$_ $ q_treevals_value_up_nodelike {
with
[t_with r0 r1 @@tree {where @@tree.up = $node and @@tree.node != @@tree.up} {}]
select value as @name0@ from ([t_with_select_nonames r0 r1])
where value like %$like%
order by node
}
$_ $ q_tree_examine_top {
select node as @name0@ ,up as @name1@ , value as @name2@
,typeof(node) as @name3@
,typeof(up) as @name4@
,typeof(value) as @name5@
,ref as @name6@
,typeof(ref) as reftype
from (
with
[t_with r0 r1 @@tree {} {}]
[t_with_select_nonames r0 r1]
)
}
$_ $ q_walk_root {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = @@tree.up or not exists (
select 1 from @@tree as tree2 where tree2.node = @@tree.up
)} [t_recurse r0]]
[t_with_select r0 r1]
}
$_ $ q_walk_node {
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
[t_with_select r0 r1]
}
$_ $ s_delete_node {
delete from "@@values" where
(
select count(*) from @@link where node = $node
) == 0
and (
select count(*) from @@tree where value
= (
select value from @@tree where node = $node
)
and node not in (select node from @@link)
) == 1
and "@@values".node = (select value from @@tree where node = $node)
; delete from @@link where @@link.node = $node
; delete from @@tree where node = $node
}
$_ $ s_insert_value {
create temp table if not exists @@tree_insert_value (
value integer primary key
) without rowid
; delete from @@tree_insert_value
; insert into @@tree_insert_value select coalesce(
(select max(node)+1 from @@tree) ,0)
; insert or ignore into "@@values" values (null ,[lossless \$value])
; insert into @@tree values (
(select value from @@tree_insert_value)
,$up
,(select node from "@@values"
where value = [lossless \$value])
)
; select value from @@tree_insert_value
}
$_ $ s_insert_link {
create temp table if not exists @@tree_insert_link (
value integer primary key
) without rowid
; delete from @@tree_insert_link
; insert into @@tree_insert_link select coalesce(
(select max(node)+1 from @@tree) ,0)
-- inserts NULL if the variable "value" does not exist in the local
-- scope
-- to do: is this behaviour accounted for everywhere?
; insert into @@tree values (
(select value from @@tree_insert_link)
,$up
,$value
)
; insert into @@link select value from @@tree_insert_link
; select value from @@tree_insert_link
}
$_ $ s_move_to {
; update @@tree set up = $to where node = $node
}
$_ $ s_node_cp {
create temp table @@tree_cp (
node integer primary key
, orignode numeric
, origlink numeric
, up numeric
, value numeric
)
;insert into @@tree_cp
with recursive
[t_with r0 r1 @@tree {where @@tree.node = $node} [t_recurse r0]]
select
coalesce((select max(node) + 1 from @@tree), 0)
+ row_number() over ()
as newnode
, node
, link
,up
, ref
from ([t_with_select_raw_nonames r0]) as t1
; insert into @@link select node from @@tree_cp
where origlink is not null
; update @@tree_cp as t1 set value = (
select t2.value
from @@tree_cp as t2
where t2.orignode = t1.origlink
) where origlink in ( select orignode from @@tree_cp )
; insert into @@tree select node
,
case
when orignode = $node then $to
else (
select t2.node from @@tree_cp as t2
where t1.up = t2.orignode
)
end
,value
from @@tree_cp as t1
; drop table @@tree_cp
}
$_ $ sql_select_tree_forth {
select coalesce(max(node) + 1, 0) from @@tree
}
$_ $ sql_create_table_readmap {
create table if not exists @@readmap (
old integer primary key
,new numeric
) without rowid
; delete from @@readmap
}
$_ $ sql_link_delete {
delete from @@link where node = $node
}
$_ $ sql_readchan_delete {
delete from @@readchan_value where id = $id
}
if 0 {
this didn't work because sqlite's incrblob can't write files of
arbitrary size into the database.
$_ $ sql_readchan_tmptable {
create table if not exists @@readchan_value (
id integer primary key
,value integer
)
; delete from @@readchan_value
; insert into @@readchan_value values (null ,'')
; select last_insert_rowid() from @@readchan_value
}
$_ $ sql_readchan_queryvalues {
select node from "@@values" where value = (
select value from @@readchan_value
where id = $id
)
}
$_ $ sql_readchan_insert {
insert or ignore into "@@values"
select null ,value
from @@readchan_value
where id = $id
; update @@tree set value = (
select node from "@@values" where value = (
select value from @@readchan_value where id = $id
)
) where node = $newnode
}
}
$_ $ sql_delete_table_readmap {
; delete from @@readmap
}
$_ $ sql_select_table_readmap {
select old, new from @@readmap
}
$_ $ sql_insert_table_readmap {
insert into @@readmap values (
$node
, $new
)
}
$_ $ sql_repoint {
update @@tree set value = $target where node = $node
}
$_ $ sql_table_tree_readmap {
update @@tree set up = (
select new from @@readmap where @@tree.up = @@readmap.old
) where @@tree.node in (select new from @@readmap)
; update @@tree set value = (
select new from @@readmap where @@tree.value = @@readmap.old
) where @@tree.node in (select new from @@readmap)
and @@tree.node in (select node from @@link)
}
$_ $ sql_values_count {
select count(*) from "@@values"
}
$_ $ sql_value_get {
select value from "@@values" where node = $id
}
}]
} [namespace current]]
accelerate
}] ;# end string map
} [namespace current]] ;# end ::apply