mirror of
https://github.com/sqlite/sqlite.git
synced 2024-11-29 00:12:23 +01:00
293 lines
8.2 KiB
Plaintext
293 lines
8.2 KiB
Plaintext
# 2021 September 13
|
|
#
|
|
# The author disclaims copyright to this source code. In place of
|
|
# a legal notice, here is a blessing:
|
|
#
|
|
# May you do good and not evil.
|
|
# May you find forgiveness for yourself and forgive others.
|
|
# May you share freely, never taking more than you give.
|
|
#
|
|
#***********************************************************************
|
|
#
|
|
# The focus of this file is testing the r-tree extension.
|
|
#
|
|
|
|
if {![info exists testdir]} {
|
|
set testdir [file join [file dirname [info script]] .. .. test]
|
|
}
|
|
source [file join [file dirname [info script]] rtree_util.tcl]
|
|
source $testdir/tester.tcl
|
|
set testprefix rtreedoc3
|
|
|
|
ifcapable !rtree {
|
|
finish_test
|
|
return
|
|
}
|
|
|
|
|
|
# This command assumes that the argument is a node blob for a 2 dimensional
|
|
# i32 r-tree table. It decodes and returns a list of cells from the node
|
|
# as a list. Each cell is itself a list of the following form:
|
|
#
|
|
# {$rowid $minX $maxX $minY $maxY}
|
|
#
|
|
# For internal (non-leaf) nodes, the rowid is replaced by the child node
|
|
# number.
|
|
#
|
|
proc rnode_cells {aData} {
|
|
set nDim 2
|
|
|
|
set nData [string length $aData]
|
|
set nBytePerCell [expr (8 + 2*$nDim*4)]
|
|
binary scan [string range $aData 2 3] S nCell
|
|
|
|
set res [list]
|
|
for {set i 0} {$i < $nCell} {incr i} {
|
|
set iOff [expr $i*$nBytePerCell+4]
|
|
set cell [string range $aData $iOff [expr $iOff+$nBytePerCell-1]]
|
|
binary scan $cell WIIII rowid x1 x2 y1 y2
|
|
lappend res [list $rowid $x1 $x2 $y1 $y2]
|
|
}
|
|
|
|
return $res
|
|
}
|
|
|
|
# Interpret the first two bytes of the blob passed as the only parameter
|
|
# as a 16-bit big-endian integer and return the value. If this blob is
|
|
# the root node of an r-tree, this value is the height of the tree.
|
|
#
|
|
proc rnode_height {aData} {
|
|
binary scan [string range $aData 0 1] S nHeight
|
|
return $nHeight
|
|
}
|
|
|
|
# Return a blob containing node iNode of r-tree "rt".
|
|
#
|
|
proc rt_node_get {iNode} {
|
|
db one { SELECT data FROM rt_node WHERE nodeno=$iNode }
|
|
}
|
|
|
|
|
|
#--------------------------------------------------------------
|
|
# API:
|
|
#
|
|
# pq_init
|
|
# Initialize a new test.
|
|
#
|
|
# pq_test_callback
|
|
# Invoked each time the xQueryCallback function is called. This Tcl
|
|
# command checks that the arguments that SQLite passed to xQueryCallback
|
|
# are as expected.
|
|
#
|
|
# pq_test_row
|
|
# Invoked each time a row is returned. Checks that the row returned
|
|
# was predicted by the documentation.
|
|
#
|
|
# DATA STRUCTURE:
|
|
# The priority queue is stored as a Tcl list. The order of elements in
|
|
# the list is unimportant - it is just used as a set here. Each element
|
|
# in the priority queue is itself a list. The first element is the
|
|
# priority value for the entry (a real). Following this is a list of
|
|
# key-value pairs that make up the entries fields.
|
|
#
|
|
proc pq_init {} {
|
|
global Q
|
|
set Q(pri_queue) [list]
|
|
|
|
set nHeight [rnode_height [rt_node_get 1]]
|
|
set nCell [llength [rnode_cells [rt_node_get 1]]]
|
|
|
|
# EVIDENCE-OF: R-54708-13595 An R*Tree query is initialized by making
|
|
# the root node the only entry in a priority queue sorted by rScore.
|
|
lappend Q(pri_queue) [list 0.0 [list \
|
|
iLevel [expr $nHeight+1] \
|
|
iChild 1 \
|
|
iCurrent 0 \
|
|
]]
|
|
}
|
|
|
|
proc pq_extract {} {
|
|
global Q
|
|
if {[llength $Q(pri_queue)]==0} {
|
|
error "priority queue is empty!"
|
|
}
|
|
|
|
# Find the priority queue entry with the lowest score.
|
|
#
|
|
# EVIDENCE-OF: R-47257-47871 Smaller scores are processed first.
|
|
set iBest 0
|
|
set rBestScore [lindex $Q(pri_queue) 0 0]
|
|
for {set ii 1} {$ii < [llength $Q(pri_queue)]} {incr ii} {
|
|
set rScore [expr [lindex $Q(pri_queue) $ii 0]]
|
|
if {$rScore<$rBestScore} {
|
|
set rBestScore $rScore
|
|
set iBest $ii
|
|
}
|
|
}
|
|
|
|
# Extract the entry with the lowest score from the queue and return it.
|
|
#
|
|
# EVIDENCE-OF: R-60002-49798 The query proceeds by extracting the entry
|
|
# from the priority queue that has the lowest score.
|
|
set ret [lindex $Q(pri_queue) $iBest]
|
|
set Q(pri_queue) [lreplace $Q(pri_queue) $iBest $iBest]
|
|
|
|
return $ret
|
|
}
|
|
|
|
proc pq_new_entry {rScore iLevel cell} {
|
|
global Q
|
|
|
|
set rowid_name "iChild"
|
|
if {$iLevel==0} { set rowid_name "iRowid" }
|
|
|
|
set kv [list]
|
|
lappend kv aCoord [lrange $cell 1 end]
|
|
lappend kv iLevel $iLevel
|
|
|
|
if {$iLevel==0} {
|
|
lappend kv iRowid [lindex $cell 0]
|
|
} else {
|
|
lappend kv iChild [lindex $cell 0]
|
|
lappend kv iCurrent 0
|
|
}
|
|
|
|
lappend Q(pri_queue) [list $rScore $kv]
|
|
}
|
|
|
|
proc pq_test_callback {L res} {
|
|
#pq_debug "pq_test_callback $L -> $res"
|
|
global Q
|
|
|
|
array set G $L ;# "Got" - as in stuff passed to xQuery
|
|
|
|
# EVIDENCE-OF: R-65127-42665 If the extracted priority queue entry is a
|
|
# node (a subtree), then the next child of that node is passed to the
|
|
# xQueryFunc callback.
|
|
#
|
|
# If it had been a leaf, the row should have been returned, instead of
|
|
# xQueryCallback being called on a child - as is happening here.
|
|
foreach {rParentScore parent} [pq_extract] {}
|
|
array set P $parent ;# "Parent" - as in parent of expected cell
|
|
if {$P(iLevel)==0} { error "query callback mismatch (1)" }
|
|
set child_node [rnode_cells [rt_node_get $P(iChild)]]
|
|
set expected_cell [lindex $child_node $P(iCurrent)]
|
|
set expected_coords [lrange $expected_cell 1 end]
|
|
if {[llength $expected_coords] != [llength $G(aCoord)]} {
|
|
puts [array get P]
|
|
puts "E: $expected_coords G: $G(aCoord)"
|
|
error "coordinate mismatch in query callback (1)"
|
|
}
|
|
foreach a [lrange $expected_cell 1 end] b $G(aCoord) {
|
|
if {$a!=$b} { error "coordinate mismatch in query callback (2)" }
|
|
}
|
|
|
|
# Check level is as expected
|
|
#
|
|
if {$G(iLevel) != $P(iLevel)-1} {
|
|
error "iLevel mismatch in query callback (1)"
|
|
}
|
|
|
|
# Unless the callback returned NOT_WITHIN, add the entry to the priority
|
|
# queue.
|
|
#
|
|
# EVIDENCE-OF: R-28754-35153 Those subelements for which the xQueryFunc
|
|
# callback sets eWithin to PARTLY_WITHIN or FULLY_WITHIN are added to
|
|
# the priority queue using the score supplied by the callback.
|
|
#
|
|
# EVIDENCE-OF: R-08681-45277 Subelements that return NOT_WITHIN are
|
|
# discarded.
|
|
set r [lindex $res 0]
|
|
set rScore [lindex $res 1]
|
|
if {$r!="fully" && $r!="partly" && $r!="not"} {
|
|
error "unknown result: $r - expected \"fully\", \"partly\" or \"not\""
|
|
}
|
|
if {$r!="not"} {
|
|
pq_new_entry $rScore [expr $P(iLevel)-1] $expected_cell
|
|
}
|
|
|
|
# EVIDENCE-OF: R-07194-63805 If the node has more children then it is
|
|
# returned to the priority queue. Otherwise it is discarded.
|
|
incr P(iCurrent)
|
|
if {$P(iCurrent)<[llength $child_node]} {
|
|
lappend Q(pri_queue) [list $rParentScore [array get P]]
|
|
}
|
|
}
|
|
|
|
proc pq_test_result {id x1 x2 y1 y2} {
|
|
#pq_debug "pq_test_result $id $x1 $x2 $y1 $y2"
|
|
foreach {rScore next} [pq_extract] {}
|
|
|
|
# The extracted entry must be a leaf (otherwise, xQueryCallback would
|
|
# have been called on the extracted entries children instead of just
|
|
# returning the data).
|
|
#
|
|
# EVIDENCE-OF: R-13214-54017 If that entry is a leaf (meaning that it is
|
|
# an actual R*Tree entry and not a subtree) then that entry is returned
|
|
# as one row of the query result.
|
|
array set N $next
|
|
if {$N(iLevel)!=0} { error "result row mismatch (1)" }
|
|
|
|
if {$x1!=[lindex $N(aCoord) 0] || $x2!=[lindex $N(aCoord) 1]
|
|
|| $y1!=[lindex $N(aCoord) 2] || $y2!=[lindex $N(aCoord) 3]
|
|
} {
|
|
if {$N(iLevel)!=0} { error "result row mismatch (2)" }
|
|
}
|
|
|
|
if {$id!=$N(iRowid)} { error "result row mismatch (3)" }
|
|
}
|
|
|
|
proc pq_done {} {
|
|
global Q
|
|
# EVIDENCE-OF: R-57438-45968 The query runs until the priority queue is
|
|
# empty.
|
|
if {[llength $Q(pri_queue)]>0} {
|
|
error "priority queue is not empty!"
|
|
}
|
|
}
|
|
|
|
proc pq_debug {caption} {
|
|
global Q
|
|
|
|
puts "**** $caption ****"
|
|
set i 0
|
|
foreach q [lsort -real -index 0 $Q(pri_queue)] {
|
|
puts "PQ $i: $q"
|
|
incr i
|
|
}
|
|
}
|
|
|
|
#--------------------------------------------------------------
|
|
|
|
proc box_query {a} {
|
|
set res [list fully [expr rand()]]
|
|
pq_test_callback $a $res
|
|
return $res
|
|
}
|
|
|
|
register_box_query db box_query
|
|
|
|
do_execsql_test 1.0 {
|
|
CREATE VIRTUAL TABLE rt USING rtree_i32(id, x1,x2, y1,y2);
|
|
WITH s(i) AS (
|
|
SELECT 0 UNION ALL SELECT i+1 FROM s WHERE i<64
|
|
)
|
|
INSERT INTO rt SELECT NULL, a.i, a.i+1, b.i, b.i+1 FROM s a, s b;
|
|
}
|
|
|
|
proc box_query {a} {
|
|
set res [list fully [expr rand()]]
|
|
pq_test_callback $a $res
|
|
return $res
|
|
}
|
|
|
|
pq_init
|
|
db eval { SELECT id, x1,x2, y1,y2 FROM rt WHERE id MATCH qbox() } {
|
|
pq_test_result $id $x1 $x2 $y1 $y2
|
|
}
|
|
pq_done
|
|
|
|
finish_test
|
|
|
|
|