### teststorage.tcl --
##
## Test the TGraph storage object's commands:
##
## Copyright (c) 2000-2003, JYL Software Inc.
## 
## Permission is hereby granted, free of charge, to any person obtaining
## a copy of this software and associated documentation files (the
## "Software"), to deal in the Software without restriction, including
## without limitation the rights to use, copy, modify, merge, publish,
## distribute, sublicense, and/or sell copies of the Software, and to
## permit persons to whom the Software is furnished to do so, subject to
## the following conditions:
## 
## The above copyright notice and this permission notice shall be
## included in all copies or substantial portions of the Software.
## 
## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
## LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
## OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
## WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE, EVEN IF
## JYL SOFTWARE INC. IS MADE AWARE OF THE POSSIBILITY OF SUCH DAMAGE.

# Require the tcltest package:

package require tcltest

# Load some utilities:

source [file join [file dirname [info script]] util.tcl]

# The tests:

# Storages should be created empty and should not be unstable initially:

tcltest::test storage-1.0.0 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    if {![$x isstable]} {
	deleteAndError $x "Storage $x is unstable but unchanged"
    }
    $x delete
    set empty
} ""

# Storages should have auto-commit on initially:

tcltest::test storage-1.0.1 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    if {[$x configure -commitatclose] == 0} {
	deleteAndError $x "Storage $x should have -commitatclose 1"
    }
    $x configure -commitatclose 0
    if {[$x configure -commitatclose] == 1} {
	deleteAndError $x "Storage $x should have -commitatclose 0"
    }
    $x delete
    set empty
} ""

# Storages should be stable after deletion:

tcltest::test storage-1.0.2 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    $x commit
    $x delete
    set x [tgraph::open foo.db]
    if {![$x isstable]} {
	deleteAndError $x "Storage $x should be not unstable initially"
    }
    $x delete
    set empty
} ""

# Storages should auto-commit on close if auto-commit is on:

tcltest::test storage-1.0.4 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    set r [$x root]
    $r add foo last 23
    $x close
    set x [tgraph::open foo.db]
    set r [$x root]
    if {[$r vertexcount] != 1} {
	deleteAndError $x "Storage $x should be non-empty after auto-commit"
    }
    $x delete
    set empty
} ""

# Storages should have the same contents before and after commit-close-open

tcltest::test storage-1.0.5 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    set r [$x root]
    $r add foo last 23
    $x close
    set x [tgraph::open foo.db]
    set r [$x root]
    if {[$r vertexcount] != 1} {
	deleteAndError $x "Storage $x should have root with one vertex"
    }
    if {[$r get foo] != 23} {
	deleteAndError $x "Storage $x should have vertex foo with value 23"
    }
    $x delete
    set empty
} ""

# Test $storage name, $storage driver and $storage mode:

tcltest::test storage-1.0.6 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    if {![string equal [$x name] foo.db]} {
	deleteAndError $x "Storage $x should have the name \"foo.db\""
    }
    if {![string equal [$x configure -rwmode] rw]} {
	deleteAndError $x "Storage $x should have mode \"rw\""
    }
    if {![string equal [$x configure -driver] "Metakit 2.4"]} {
	deleteAndError $x "Storage $x should have driver \"Metakit 2.4\""
    }
    $x delete
    set empty
} ""

# Mark a storage unstable and see if it is marked unstable..

tcltest::test storage-1.0.7 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    if {![$x isstable]} {
	deleteAndError $x "Storage $x should not be unstable initially"
    }
    $x markunstable
    if {[$x isstable]} {
	deleteAndError $x "Storage $x should be marked unstable"
    }
    $x commit
    if {![$x isstable]} {
	deleteAndError $x "Storage $x should not be marked unstable after commit"
    }
    $x delete
    set empty
} ""

# Test $storage statistic operation on an empty storage.

tcltest::test storage-1.0.10 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    if {[$x statistic node used] != 1} {
	deleteAndError $x "Storage $x statistic node used != 1"
    }
    if {[$x statistic node freed] != 0} {
	deleteAndError $x "Storage $x statistic node freed != 0"
    }
    if {[$x statistic node available] != 128} {
	deleteAndError $x "Storage $x statistic node available != 128"
    }
    if {[$x statistic node allocated] != 1} {
	deleteAndError $x "Storage $x statistic node allocated != 1"
    }
    if {[$x statistic vertex used] != 0} {
	deleteAndError $x "Storage $x statistic vertex used != 0"
    }
    if {[$x statistic vertex freed] != 0} {
	deleteAndError $x "Storage $x statistic vertex freed != 0"
    }
    if {[$x statistic vertex available] != 0} {
	deleteAndError $x "Storage $x statistic vertex available != 0"
    }
    if {[$x statistic vertex allocated] != 0} {
	deleteAndError $x "Storage $x statistic vertex allocated != 0"
    }
    $x delete
    set empty
} ""

# Test $storage statistic after some allocations.

tcltest::test storage-1.0.11 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    set r [$x root]

    if {[$x statistic node allocated] != 1} {
	deleteAndError $x "storage $x statistic node allocated != 1"
    }

    for {set i 0} {$i < 10} {incr i} {
	$r addnode frob$i last
    }
    
    # There should be eleven nodes allocated, and space for 128.
    # No frees have happened, so the statistics for those should be 0.

    if {[$x statistic node used] != 11} {
	deleteAndError $x "Storage $x statistic node used != 11"
    }
    if {[$x statistic node freed] != 0} {
	deleteAndError $x "Storage $x statistic node freed != 0"
    }
    if {[$x statistic node available] != 128} {
	deleteAndError $x "Storage $x statistic node available != 128"
    }
    if {[$x statistic node allocated] != 11} {
	deleteAndError $x "Storage $x statistic node allocated != 11"
    }
    if {[$x statistic vertex used] != 10} {
	deleteAndError $x "Storage $x statistic vertex used != 0"
    }
    if {[$x statistic vertex freed] != 0} {
	deleteAndError $x "Storage $x statistic vertex freed != 0"
    }
    if {[$x statistic vertex available] != 128} {
	deleteAndError $x "Storage $x statistic vertex available != 128"
    }
    if {[$x statistic vertex allocated] != 10} {
	deleteAndError $x "Storage $x statistic vertex allocated != 10"
    }

    # Now delete all the nodes and see if the freed statistic is
    # correctly updated.

    for {set i 0} {$i < 10} {incr i} {
	$r detachvertex 1
    }

    if {[$x statistic node used] != 1} {
	deleteAndError $x "Storage $x statistic node used != 0"
    }
    if {[$x statistic node freed] != 10} {
	deleteAndError $x "Storage $x statistic node freed != 10"
    }
    if {[$x statistic node available] != 128} {
	deleteAndError $x "Storage $x statistic node available != 128"
    }
    if {[$x statistic node allocated] != 11} {
	deleteAndError $x "Storage $x statistic node allocated != 11"
    }
    if {[$x statistic vertex used] != 0} {
	deleteAndError $x "Storage $x statistic vertex used != 0"
    }
    if {[$x statistic vertex freed] != 10} {
	deleteAndError $x "Storage $x statistic vertex freed != 10"
    }
    if {[$x statistic vertex available] != 128} {
	deleteAndError $x "Storage $x statistic vertex available != 128"
    }
    if {[$x statistic vertex allocated] != 10} {
	deleteAndError $x "Storage $x statistic vertex allocated != 10"
    }
    $x delete
    set empty
} ""

# Test storage foreach operation

tcltest::test storage-1.0.12 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    set r [$x root]

    # Allocate some entities into the storage.

    for {set i 0} {$i < 100} {incr i} {
	set n [$r addnode foo last]
	for {set j 0} {$j < 10} {incr j} {
	    $n add v$j last $j
	}
    }

    # We now have 101 nodes and 1000 vertices.

    set ncount 0
    set vcount 0

    $x foreach node n {incr ncount}
    $x foreach vertex v {incr vcount}

    if {$ncount != 101} {
	deleteAndError $x "\"storage foreach node\" didn't visit all nodes"
    }
    if {$vcount != 1100} {
	deleteAndError $x \
		"\"storage foreach vertex\" didn't visit all vertices $vcount"
    }

    # One more check: sum the value of all vertices -- we should get
    # (0+1+2+3+4+5+6+7+8+9) * 100 which is 4500.

    set sum 0
    $x foreach vertex v {
	if {[$v type] == "int"} {
	    incr sum [$v get]
	}
    }
    if {$sum != 4500} {
	deleteAndError $x \
		"\"storage foreach vertex\" didn't visit all vertices once"
    }
    $x delete
    set empty
} ""

# Test storage callback operation various operations

proc cb {v en} {
    upvar #0 $v counter

    incr counter
}

tcltest::test storage-1.0.13 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    set r [$x root]

    # Install callbacks:

    set callbacks($x,vertex,det) [$x callback add vertex det "cb vdetcb"]
    set callbacks($x,node,det) [$x callback add node det "cb ndetcb"]

    # Initialize counters:

    set ndetcb 0
    set vdetcb 0

    # Create tree structure. After this step, v holds a vertex inside
    # a node in the root (a second level vertex).

    set n [$r addnode foo last]
    $n add foo last 1
    set v [$n getvertex foo]
    unset n

    # Cause callbacks to happen:

    $r detachvertex foo

    # Check that the vertex is in fact detached:

    if {[$v isdetached] == 0} {
	deleteAndError $x "vertex $v id not detached!"
    }

    # The root should now be empty:

    if {[$r vertexcount] != 0} {
	deleteAndError $x \
	    "root not empty as expected, [$r vertexcount] vertices left"
    }

    # Now see if exactly 0 node detach and 1 vertex detach callbacks occurred.

    if {$ndetcb != 0} {
	deleteAndError $x "Expected 0 node detach callback, got $ndetcb"
    }
    if {$vdetcb != 1} {
	deleteAndError $x "Expected 1 vertex detach callback, got $vdetcb"
    }
    $x delete
    set empty
} ""

tcltest::test storage-1.0.14 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    set r [$x root]

    # Install some callbacks:

    set callbacks($x,node,add) [$x callback add node add "cb naddcb"]
    set callbacks($x,node,det) [$x callback add node det "cb ndetcb"]
    set callbacks($x,node,mod) [$x callback add node mod "cb nmodcb"]
    set callbacks($x,vertex,add) [$x callback add vertex add "cb vaddcb"]
    set callbacks($x,vertex,det) [$x callback add vertex det "cb vdetcb"]
    set callbacks($x,vertex,mod) [$x callback add vertex mod "cb vmodcb"]

    # Initialize all counters to zero:

    set naddcb 0
    set ndetcb 0
    set nmodcb 0
    set vaddcb 0
    set vdetcb 0
    set vmodcb 0

    # Allocate some entities in the storage.

    for {set i 0} {$i < 100} {incr i} {
	set n [$r addnode foo last]
	for {set j 0} {$j < 10} {incr j} {
	    $n add v$j last $j
	}
    }

    # We now have 101 nodes and 1100 vertices.

    set ncount 0
    set vcount 0

    $x foreach node n {incr ncount}
    $x foreach vertex v {incr vcount}

    if {$ncount != 101} {
	deleteAndError $x "\"storage foreach node\" didn't visit all nodes"
    }
    if {$vcount != 1100} {
	deleteAndError $x \
		"\"storage foreach vertex\" didn't visit all vertices"
    }

    # One more check: sum the value of all vertices -- we should get
    # (0+1+2+3+4+5+6+7+8+9) * 100 which is 4500.

    set sum 0
    $x foreach vertex v {
	if {[$v type] == "int"} {
	    incr sum [$v get]}
    }
    if {$sum != 4500} {
	deleteAndError $x \
		"\"storage foreach vertex\" didn't visit all vertices once"
    }

    # Now check we had the correct number of callbacks:

    if {$naddcb != 100} {
	deleteAndError $x "\"storage callback\" incorrect number of add node callbacks $naddcb"
    }
    if {$nmodcb != 1100} {
	deleteAndError $x "\"storage callback\" incorrect number of mod node callbacks $nmodcb"
    }
    if {$vaddcb != 0} {
	deleteAndError $x "\"storage callback\" incorrect number of add vertex callbacks $vaddcb"
    }
    if {$ndetcb != 0} {
	deleteAndError $x "\"storage callback\" incorrect number of det node callbacks $ndetcb"
    }
    if {$vdetcb != 0} {
	deleteAndError $x "\"storage callback\" incorrect number of det vertex callbacks $vdetcb"
    }
    if {$vmodcb != 0} {
	deleteAndError $x "\"storage callback\" incorrect number of mod vertex callbacks $vmodcb"
    }

    # Now modify all vertices:

    $x foreach vertex v {
	if {[$v type] == "int"} {
	    $v set 100
	}
    }

    if {$vmodcb != 1000} {
	deleteAndError $x "1000 vs $vmodcb: incorrect mod callbacks here"
    }

    $x delete
    set empty
} ""

tcltest::test storage-1.0.15 {storage tests} {
    showActive
    set empty ""
    set x [ensureFreshStorage foo.db]
    set r [$x root]

    # Install detach callbacks

    $x callback add node det "cb ndetcb"
    $x callback add vertex det "cb vdetcb"

    # Initialize counters to zero:

    set ndetcb 0
    set vdetcb 0

    # Allocate some entities in the storage.

    for {set i 0} {$i < 100} {incr i} {
	set n [$r addnode foo last]
	for {set j 0} {$j < 10} {incr j} {
	    $n add v$j last $j
	}
    }

    set n [$r get 33]
    set v [$n getvertex 3]
    set n [$r get 23]

    # Now detach everything:

    for {set i 0} {$i < 100} {incr i} {
	$r detachvertex 1
    }

    # Check that both saved entities are now detached.

    if {[$n isdetached] == 0} {
	deleteAndError $x "node $n is not detached!"
    }
    if {[$v isdetached] == 0} {
	deleteAndError $x "vertex $v is not detached!"
    }

    # The root should now be empty

    if {[$r vertexcount] != 0} {
	deleteAndError $x \
	    "root not empty as expected, [$r vertexcount] vertices left"
    }

    # Now see if exactly 1 node detach and 1 vertex detach callbacks occurred.

    if {$ndetcb != 1} {
	deleteAndError $x "Expected 1 node detach callback, got $ndetcb"
    }
    if {$vdetcb != 1} {
	deleteAndError $x "Expected 1 vertex detach callback, got $vdetcb"
    }

    $x delete

    set empty
} ""
