Adding upstream version 3.40.1.upstream/3.40.1upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 292 insertions, 0 deletions

diff --git a/ext/rtree/rtreedoc3.test b/ext/rtree/rtreedoc3.test
new file mode 100644
index 0000000..0403409
--- /dev/null
+++ b/ext/rtree/rtreedoc3.test
@@ -0,0 +1,292 @@
+# 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
+
+