Web::Chain project:    Web/t/Web-Chain.t

     # Test file created outside of h2xs framework.
# Run this like so: `perl Web-Chain.t'
#   doom@kzsu.stanford.edu     2004/08/28 18:14:49

#########################

use warnings;
use strict;
$|=1;

use Test::More;
BEGIN { plan tests => 49 };

use Web::Chain;

use Web::Definitions qw($DEBUG);  
# $DEBUG = 1; # Turn on verbose reporting 
# (over-riding group wide default setting from Web::Definitions)

###=======
### Utility functions used in the following tests

sub check_node_names_against_exists_hash {
  # Example: 
  #    check_node_names_against_exists_hash($chain_object); 
  # (Yes, this is proceedural code that requires an object as an argument. Sue me.)
  # 
  # Compares the existing node names to the ones recorded in the internal _exists hash.
  # (I'm getting a difference somewhere, and I want to track it down.)

  my $chain = shift;
  my $label = shift;  # optional label used to prefix report string

  my @names = $chain->get_names();

  my $hashref = $chain->get_exists_hashref;
  my @seens = sort (keys %{ $hashref });

  my @sorted_names = sort @names;
  ($DEBUG) && print STDERR "  exists: " . join( ' ', @seens ) . "\n";
  ($DEBUG) && print STDERR "  nodes:  " . join( ' ', @sorted_names ) . "\n";

  my $first_name = $chain->get_beg->get_name;

  is_deeply(\@seens, \@sorted_names ," $label chain beginning with $first_name passes comparison of _exists hash and scan contained nodes");

}

###=======
### Into the tests proper

ok(1); # If we made it this far, we're ok.

# Tests originally created following the SYNOPSIS (other tests added as I went)

#--------
# raw material - node names to be created, some minimal text to use as node bodies,
#                initilize: create chain object.

my @node_name=qw(ONE TWO THREE FOUR FIVE SIX);
my @node_body=qw(one two three four five six);

my $chain1 = Web::Chain->new();

#--------
# Add a single node to the chain

$chain1->add_link($node_name[0]);  # no "after_node_name" so should be first
$chain1->set_body($node_name[0], \$node_body[0]);

my $test_name = $chain1->get_name_from_offset(0);
is($test_name, $node_name[0], "Newly created node reports correct name");

my $test_body = ${ $chain1->get_body_from_offset(0) };
is($test_body, $node_body[0], "Newly created node reports correct body");

# peeking at internal "_exists" hash to see if the node name was added correctly
my @seen = (keys %{ $chain1->{_exists} } );

is($seen[0], $node_name[0] ,"The chain records that it has seen the name of newly created node");

my $end_name = $chain1->get_end->get_name;
is( $end_name, $node_name[0], "Test that get_end returns the only node of a single node chain.");


#--------
# checking internally used routine: _handle_node_argument
#   simplest possible case: undef argument
my $nada = $chain1->_handle_node_argument();
is($nada, undef, "_handle_node_argument returns undef when given an undef");
#   given $node, passes through $node)
my $some_node = $chain1->{_beg};
my $test_node = $chain1->_handle_node_argument($some_node);
is($test_node, $some_node, "_handle_node_argument: Given a node object, passes it through");

#  should error when given an object of the wrong type (here a chain rather than a node):
eval { 
  my $test_object = $chain1->_handle_node_argument($chain1);
### TODO play with this stuff some time:
#  my $node_class = ref($some_node);
#  isa_ok($test_object, $node_class);
#  isnt($test_object, $chain1, 
#       "_handle_node_argument: Given object of wrong type, should error out, not pass through object like this.");
} ;
like($@, qr/ _handle_node_argument: \s+ argument \s+ type \s+ /x, 
    "_handle_node_argument: errored out when given a non-node object");

#  should error when given a name not in use for an existing link
eval { 
  my $test_object = $chain1->_handle_node_argument('GARUDATECH');
} ;
like($@, qr/ _handle_node_argument: \s+ GARUDATECH \s+ is \s+ not \s+ the \s+ name \s+ of \s+ a \s+ node \s+ /x, 
    "_handle_node_argument: errored out when given a name for a node that doesn't exist");

#--------
# Continue adding links to the chain one at a time, 
# verify that links were added using get_names

for (my $i=1; $i <= $#node_name ; $i++) { 
  $chain1->add_link($node_name[$i], $node_name[$i-1]);  
  $chain1->set_body( $node_name[$i], \$node_body[$i] );
}

my @sequence = $chain1->get_names();
is_deeply(\@node_name, \@sequence, "Created chain reports correct node names");

# peeking at internal "_exists" hash to see if the node names are all there:

check_node_names_against_exists_hash($chain1, 'chain1: ');

#--------
### TODO update or DELETE this silly comment:
# Similar checks for the alternate form ((?)), doing it all in one step ((?))
# 
#  Create a modified set of names and bodies to work with
my @node_name_a = map { $_ . '_A' } @node_name;
my @node_body_a = map { $_ . '_A' } @node_body;

my $last_indicie = $#node_name;

$chain1->add_link($node_name_a[0], $node_name[$last_indicie]);
$chain1->set_body($node_name_a[0], \$node_body_a[0]);

my $next_indicie = $last_indicie + 1;

@sequence = $chain1->get_names();

$test_name = $chain1->get_name_from_offset($next_indicie);
is($test_name, $node_name_a[0], "Newly created node reports correct name");

$test_body = ${ $chain1->get_body_from_offset($next_indicie) };
is($test_body, $node_body_a[0] , "Newly created node reports correct body");

check_node_names_against_exists_hash($chain1, 'chain1: ');

for (my $i=1; $i<=$#node_name; $i++) { 
  $chain1->add_link($node_name_a[$i], $node_name_a[$i-1], \$node_body_a[$i]);

  check_node_names_against_exists_hash($chain1, 'chain1: ');

}

my @sequence_a = $chain1->get_names();

my @test_sequence;  
push @test_sequence, @node_name;
push @test_sequence, @node_name_a;

# use Data::Dumper; print Dumper(@test_sequence);

is_deeply(\@test_sequence, \@sequence_a, "Expanded chain reports correct node names");

check_node_names_against_exists_hash($chain1, 'chain1: ');

### ### Looking for confusion about using references:
### my $chain2 = Web::Chain->new();

### my $node_body_2th = "foal shoal and leavened scrogg awhirl";
### $chain2->add_link("SOME_NODE");  # no "after_node_name" so should be first
### $chain2->set_body("SOME_NODE", \$node_body_2th);

### my $node_body_original = $node_body_2th;  # save copy of original
### $node_body_2th = "nadzornika!";           # modify original

### my $test_body_2th = ${ $chain2->get_body_from_offset(0) };
### is($test_body_2th, $node_body_original, "Newly created node reports correct body, even though original variable changed.");

### The above fails, as expected. 
### Trying an off the top of head fix:
sub anonymoose {
  my $honker = '';
  return \$honker;
}

my $chain3 = Web::Chain->new();
my $node_body_3rd = "foal shoal and leavened scrogg awhirl our faddah art";

my $node_body_3rd_ref = anonymoose();
${ $node_body_3rd_ref } = $node_body_3rd;

$chain3->add_link("SOME_NOD");  # no "after_node_name" so should be first
$chain3->set_body("SOME_NOD", $node_body_3rd_ref);

my $node_body_original_3rd = $node_body_3rd;  # save copy of original
$node_body_3rd = "nadzornika!";           # modify original

# Trying to throw a different curve, use the moose generator again, make sure it 
# returns a new ref.
my $node_body_3rd_B_ref = anonymoose();
${ $node_body_3rd_B_ref } = "say what?";

my $test_body_3rd = ${ $chain3->get_body_from_offset(0) };
is($test_body_3rd, $node_body_original_3rd, "Newly created node reports correct body, even though original variable changed.");

### TODO 
### Okay, so I *think* that I understand *that* shit.
### (Though I bet there's a better solution than a moose generator)
### But I think there's still *another* problem I missed: 
### New chains are *not* new, but instead seem to be different pointers 
### to the same data.  Check to see if that's true, and what you need 
### to do to fix your news...

my $chain_fred  = Web::Chain->new();
my $chain_alice = Web::Chain->new();
my $chain_ted   = Web::Chain->new();

$chain_fred-> add_link("OH_FREDDY");  
$chain_alice->add_link("OH_ALICE");  
$chain_ted->  add_link("OH_TED");  

  check_node_names_against_exists_hash($chain_fred, 'chain_fred i: ');       # TEMP

my @sequence_fred = $chain_fred->get_names();
  check_node_names_against_exists_hash($chain_fred, 'chain_fred h: ');       # TEMP

is_deeply(\@sequence_fred, [ qw(OH_FREDDY) ], "different chains are different");

### checking simple node re-name behavior

$chain_fred->rename_node( 'OH_FREDDY', 'FREDDY_NO' );
  check_node_names_against_exists_hash($chain_fred, 'chain_fred g: ');       # TEMP
# Older method: 
# my $node_fred_1 = $chain_fred->get_node_from_name("OH_FREDDY");
# $node_fred_1->name("FREDDY_NO");
@sequence_fred = $chain_fred->get_names();
  check_node_names_against_exists_hash($chain_fred, 'chain_fred f: ');       # TEMP

is_deeply(\@sequence_fred, [ qw(FREDDY_NO) ], "Renaming node in single node chain");

my $node_fred_2 = $chain_fred->add_link("OH_FREDDY","FREDDY_NO");
  check_node_names_against_exists_hash($chain_fred, 'chain_fred e: ');       # TEMP

my $node_fred_3 = $chain_fred->add_link("GO_FREDDY","OH_FREDDY");
  check_node_names_against_exists_hash($chain_fred, 'chain_fred d: ');       # TEMP

@sequence_fred = $chain_fred->get_names();

($DEBUG) && print STDERR "  chain_fred: " . join(" ", @sequence_fred) . "\n";

is_deeply(\@sequence_fred, [qw(FREDDY_NO OH_FREDDY GO_FREDDY)], 
  "Created chain without name collison because of previous rename");

$chain_fred->add_link("YABBA", "GO_FREDDY");
  check_node_names_against_exists_hash($chain_fred, 'chain_fred c: ');       # TEMP

$chain_fred->add_link("DABBA", "YABBA");
  check_node_names_against_exists_hash($chain_fred, 'chain_fred b: ');       # TEMP

$chain_fred->add_link("DOOO", "DABBA");

  check_node_names_against_exists_hash($chain_fred, 'chain_fred a: ');       # TEMP

@sequence_fred = $chain_fred->get_names();
($DEBUG) && print STDERR "  chain_fred: " . join(" ", @sequence_fred) . "\n";

#--------
# Working with segments of a chain:
#   testing extract_segment method
{ 
  check_node_names_against_exists_hash($chain_fred, 'chain_fred 1: ');       # TEMP

  my $extracted_chain = $chain_fred->extract_segment("OH_FREDDY", "DABBA");

  check_node_names_against_exists_hash($chain_fred, 'chain_fred 2: ');       # TEMP
  check_node_names_against_exists_hash($extracted_chain, 'extracted_chain: ');  # TEMP

  my @sequence_extracted = $extracted_chain->get_names();
  ($DEBUG) && print STDERR "  extract from chain_fred: " . join(" ", @sequence_extracted) . "\n";
  is_deeply( \@sequence_extracted, [ qw(OH_FREDDY GO_FREDDY YABBA DABBA) ], "extract_segment method retrieves the right nodes");

  check_node_names_against_exists_hash($chain_fred, 'chain_fred 3: ');       # TEMP

  my @sequence_left_behind = $chain_fred->get_names();
  ($DEBUG) && print STDERR "  left behind in chain_fred: " . join(" ", @sequence_left_behind) . "\n";
  is_deeply( \@sequence_left_behind, [ qw(FREDDY_NO DOOO) ], "extract_segment method left behind the right nodes");
}


#  testing insert_segment
#    $chain1->insert_segment( $chain2, $after_node_name );

{ 

  @sequence_fred = $chain_fred->get_names();
  ($DEBUG) && print STDERR "  chain_fred: " . join(" ", @sequence_fred) . "\n";

  my @new_nodes = qw(BIRD MAKES NEST IN_THE_AIR);
  my $chain_jane   = Web::Chain->new();

  # By going in reverse order, can prepend to front of chain without specifying location
  foreach my $name (reverse @new_nodes) {
    $chain_jane->add_link($name);
    ### TODO set body, too?
  }

  my @expected_sequence = @sequence_fred;
  push @expected_sequence, @new_nodes;

  check_node_names_against_exists_hash($chain_jane, 'chain_jane: ');       # TEMP

  $chain_fred->insert_segment( $chain_jane, 'DOOO' );  

  check_node_names_against_exists_hash($chain_jane, 'chain_jane: ');       # TEMP
  check_node_names_against_exists_hash($chain_fred, 'chain_fred 4: ');       # TEMP **badun***
  
  my @new_sequence = $chain_fred->get_names();
  ($DEBUG) && print STDERR "  chain_fred: " . join(" ", @sequence_fred) . "\n";  

  is_deeply(\@new_sequence, \@expected_sequence, "used insert_segment to append one chain to another");

}

# globals for the following tests

my @node_letter_names = qw(NODE_A NODE_B NODE_C NODE_D NODE_E NODE_F NODE_G NODE_H);
my @node_numb_names = qw(NODE_1 NODE_2 NODE_3 NODE_4);

my $chain_letter = Web::Chain->new();
my $chain_numb = Web::Chain->new();

{ 
  foreach my $name (reverse @node_letter_names) {     # going in reverse, prepend to front of chain
    $chain_letter->add_link($name);
  }

  foreach my $name (reverse @node_numb_names) { # going in reverse, prepend to front of chain
    $chain_numb->add_link($name);
  }

  my @expected_sequence = qw(NODE_A NODE_B NODE_C NODE_D NODE_E NODE_1 NODE_2 NODE_3 NODE_4 NODE_F NODE_G NODE_H);

  $chain_letter->insert_segment( $chain_numb, 'NODE_E' );  
  
  my @new_sequence = $chain_letter->get_names();
  ($DEBUG) && print STDERR "  chain_letter: " . join(" ", @new_sequence) . "\n";  

  is_deeply(\@new_sequence, \@expected_sequence, "used insert_segment to insert chain in the middle of another");

}

# Using freshly re-defined chains
undef $chain_letter;
undef $chain_numb;
$chain_letter = Web::Chain->new();
$chain_numb = Web::Chain->new();

{ 

  foreach my $name (reverse @node_letter_names) {     # going in reverse, prepend to front of chain
    $chain_letter->add_link($name);
  }

  foreach my $name (reverse @node_numb_names) { # going in reverse, prepend to front of chain
    $chain_numb->add_link($name);
  }

  my @expected_sequence = 
    qw(NODE_1 NODE_2 NODE_3 NODE_4
       NODE_A NODE_B NODE_C NODE_D NODE_E NODE_F NODE_G NODE_H
      );

  $chain_letter->insert_segment( $chain_numb );  
  
  my @new_sequence = $chain_letter->get_names();
  ($DEBUG) && print STDERR "  chain_letter: " . join(" ", @new_sequence) . "\n";  

  is_deeply(\@new_sequence, \@expected_sequence, "used insert_segment to prepend a chain");

}

#  Testing the invalid chain argument check: _check_chain_argument

{
  my $some_node = $chain_letter->get_beg;
  my $another_node = $some_node->next;
  eval { 
    $chain_letter->insert_segment( $some_node, $another_node );  # first argument is supposed to be a chain 
    };
  if ($@) {
    like($@, qr/_check_chain_argument: \s+ argument \s+ is \s+ of \s+ type \s+ /x,
    "_check_chain_argument: insert_chain errored out when given a non-chain argument");
  }    
}

#--------
#  testing move_segment
#   $chain1->move_segment($begin_name, $end_name, $after_node_name);

{ 
  my @sequence_numb = $chain_numb->get_names();
  ($DEBUG) && print STDERR "  chain_numb: " . join(" ", @sequence_numb) . "\n";

# Current states:
#  chain_letter: NODE_1 NODE_2 NODE_3 NODE_4 NODE_A NODE_B NODE_C NODE_D NODE_E NODE_F NODE_G NODE_H
#  chain_numb: NODE_1 NODE_2 NODE_3 NODE_4 NODE_A NODE_B NODE_C NODE_D NODE_E NODE_F NODE_G NODE_H

  my  $begin_name = 'NODE_3';
  my  $end_name = 'NODE_4';
  my  $location = 'NODE_1';

  $chain_numb->move_segment($begin_name, $end_name, $location);

  my @expected = qw( NODE_1 NODE_3 NODE_4 NODE_2 NODE_A NODE_B NODE_C NODE_D NODE_E NODE_F NODE_G NODE_H );

  my @new_sequence = $chain_numb->get_names();
  
  is_deeply(\@new_sequence, \@expected, "Used move_segment to re-arrange nodes")

}

#--------
# move_segment - bounds checking
# trying to move a segment into itself should error.

# Using freshly re-defined chain
undef $chain_letter;
$chain_letter = Web::Chain->new();

{ 
  foreach my $name (reverse @node_letter_names) {     # going in reverse, prepend to front of chain
    $chain_letter->add_link($name);
  }

  my @sequence_numb = $chain_letter->get_names();
  ($DEBUG) && print STDERR "  chain_numb: " . join(" ", @sequence_numb) . "\n";

  # Expected state:  
  #       NODE_A NODE_B NODE_C NODE_D NODE_E NODE_F NODE_G NODE_H
  # (see @node_letter_names)

  my  $begin_name = 'NODE_B';
  my  $end_name = 'NODE_E';
  my  $location = 'NODE_C';

  eval { 
    $chain_numb->move_segment($begin_name, $end_name, $location);
  };

   if ($@) {
     like($@, qr/move_segment: \s+ Can't \s+ move \s+ a \s+ sub-segment \s+ of \s+ a \s+ chain \s+ into \s+ itself: \s+ /x,
          "Testing that move_segment will refuse to move a chain segment inside of itself.");
   }    
}