########################################
# test graphs using our homegrown graph implementation
# what we're mainly testing are
# 1) 'put' is really doing the Oid thing and not just dumping entire graphs
# 2) defered thawing. the various test scripts follow different paths through
# object network
# this one checks the frozen representation in the database
########################################
use t::lib;
use strict;
use Test::More;
use autodbTestObject;
use graphUtil; use Graph_010;
my($num_objects,$get_type)=@ARGV;
defined $num_objects or $num_objects=3;
defined $get_type or $get_type='get';
my $autodb=new Class::AutoDB(-database=>testdb); # open database
do_test('chain');
do_test('star');
do_test('binary_tree',-depth=>5);
do_test('ternary_tree',-depth=>5);
do_test('cycle');
do_test('clique',-nodes=>20);
do_test('cone_graph');
do_test('grid');
do_test('torus');
done_testing();
sub do_test {
my $name=shift;
my $correct_graph;
{ no strict 'refs';
$correct_graph=&$name(graph=>new Graph_010(name=>$name),@_);
}
my @correct_nodes=$correct_graph->nodes;
my @correct_edges=$correct_graph->edges;
# get actual graph
# %test_args, exported by graphUtil, sets class2colls, coll2keys, label
my $test=new autodbTestObject(%test_args,labelprefix=>"$get_type:",get_type=>$get_type);
my($actual_graph)=$test->do_get({collection=>'Graph_010',name=>$name},$get_type,1);
my @all_actual_objects=($actual_graph,$actual_graph->nodes,$actual_graph->edges);
my @actual_nodes=$actual_graph->nodes;
my @actual_edges=$actual_graph->edges;
my @all_correct_objects=($correct_graph,$correct_graph->nodes,$correct_graph->edges);
my @correct_nodes=$correct_graph->nodes;
my @correct_edges=$correct_graph->edges;
my $label="get_type: $name";
my $dbh=$autodb->dbh;
# test frozen representation of top level Graph_010
my $oid=$actual_graph->oid;
my($frozen)=$dbh->selectrow_array(qq(SELECT object FROM _AutoDB WHERE oid=$oid));
my @names=$frozen=~/name\W*=>/g;
is(scalar @names,1,"$label names in frozen Graph_010 (top level)");
my @nodes=$frozen=~/_CLASS\W*=>\W*Node/g;
is(scalar @nodes,scalar @correct_nodes,"$label nodes in frozen Graph_010 (top level)");
my @edges=$frozen=~/_CLASS\W*=>\W*Edge/g;
is(scalar @edges,scalar @correct_edges,"$label edges in frozen Graph_010 (top level)");
# test frozen representation of Nodes. walk nodes list
my $ok=1;
for my $node (@actual_nodes) {
my $oid=$node->oid;
my($frozen)=$dbh->selectrow_array(qq(SELECT object FROM _AutoDB WHERE oid=$oid));
my @names=$frozen=~/name\W*=>/g;
$ok&&=scalar(@names)==1;
my @nodes=$frozen=~/_CLASS\W*=>\W*Node/g;
$ok&&=scalar(@nodes)==scalar(@{$node->neighbors})+1; # extra 1 for node itself
my @edges=$frozen=~/_CLASS\W*=>\W*Edge/g;
$ok&&=scalar(@edges)==0; # nodes don't contain edges
}
report_pass($ok,"$label frozen nodes");
# test frozen representation of Edges. walk edges list
my $ok=1;
for my $edge (@actual_edges) {
my $oid=$edge->oid;
my($frozen)=$dbh->selectrow_array(qq(SELECT object FROM _AutoDB WHERE oid=$oid));
my @names=$frozen=~/name\W*=>/g;
$ok&&=scalar(@names)==1;
my @nodes=$frozen=~/_CLASS\W*=>\W*Node/g;
$ok&&=scalar(@nodes)==2; # edge contains 2 nodes
my @edges=$frozen=~/_CLASS\W*=>\W*Edge/g;
$ok&&=scalar(@edges)==1; # for edge itself
}
report_pass($ok,"$label frozen edges");
local $SIG{__WARN__}=sub {warn @_ unless $_[0]=~/^Deep recursion/;};
local $DB::deep=0;
# test contents the usual way.
# first, recompute transients. NO! test_get is smart enough to remove transients...
# $actual_graph->init_transients;
$test->test_get(labelprefix=>"$get_type:",
actual_object=>$actual_graph,correct_object=>$correct_graph);
}