view release on metacpan or  search on metacpan

t/autodb.020.graph/graph.010.02.thaw_edges.t  view on Meta::CPAN

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),@_);
  }
  # 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";

  # face validity. correct number of objects, nodes, edges
  is(scalar(@all_actual_objects),scalar(@all_correct_objects),
     "$label ".(scalar(@all_correct_objects)).' objects');
  is(scalar(@actual_nodes),scalar(@correct_nodes),
     "$label ".(scalar(@correct_nodes)).' nodes');
  is(scalar(@actual_edges),scalar(@correct_edges),
     "$label ".(scalar(@correct_edges)).' edges');

  # CAUTION: @correct_thawed in 'thaw' tests refers to objects in $actual_graph
  my @correct_thawed=($actual_graph);
  cmp_thawed(\@all_actual_objects,\@correct_thawed,"$label thawed Graph_010 (top level)");

 # walk edges list
  my $ok=1;
  for my $edge (@actual_edges) {
    my $ename=$edge->name;	# force thaw
    push(@correct_thawed,$edge);
    $ok&&=_cmp_thawed(\@all_actual_objects,\@correct_thawed,
		     "$label thawed edges",__FILE__,__LINE__);
  }
  report_pass($ok,"$label thawed edges");

  # walk edges' nodes (aka endpoints)
  my $ok=1;
  for my $edge (@actual_edges) {
    my($m,$n)=@{$edge->nodes};
    my $mname=$m->name;		# force thaw
    my $nname=$n->name;		# force thaw
    push(@correct_thawed,$m,$n);
    $ok&&=_cmp_thawed(\@all_actual_objects,\@correct_thawed,
		      "$label thawed edge endpoint",__FILE__,__LINE__);
  }
  report_pass($ok,"$label thawed edge endpoints");
  
  # check nodes - should all be thawed already
  cmp_thawed(\@actual_nodes,\@actual_nodes,"$label thawed nodes");

  # check neighbors lists - nodes should all be thawed already
  my @actual_neighbors=map {@{$_->neighbors}} @actual_nodes;
  cmp_thawed(\@actual_neighbors,\@actual_nodes,"$label thawed neighbors");

  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);
}