The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 48;

## ----------------------------------------------------------------------------
# NOTE:
# This specifically tests the details of the cloning functions
## ----------------------------------------------------------------------------

use Tree::Simple;

my $tree = Tree::Simple->new(Tree::Simple->ROOT);
isa_ok($tree, 'Tree::Simple');

my $test = "test";

my $SCALAR_REF = \$test;
my $REF_TO_REF = \$SCALAR_REF;
my $ARRAY_REF = [ 1, 2, 3, 4 ];
my $HASH_REF = { one => 1, two => 2 };
my $CODE_REF = sub { "code ref test" };
my $REGEX_REF = qr/^reg-ex ref/;
my $SUB_TREE = Tree::Simple->new("sub tree test");
my $MISC_OBJECT = bless({}, "Misc");

$tree->addChildren(
		Tree::Simple->new("non-ref"),	
		Tree::Simple->new($SCALAR_REF),	
		Tree::Simple->new($ARRAY_REF),
		Tree::Simple->new($HASH_REF),
		Tree::Simple->new($CODE_REF),
		Tree::Simple->new($REGEX_REF),
		Tree::Simple->new($MISC_OBJECT),
		Tree::Simple->new($SUB_TREE),
		Tree::Simple->new($REF_TO_REF)        
		);

my $clone = $tree->clone();
isa_ok($clone, 'Tree::Simple');

# make sure all the parentage is correct
is($clone->getParent(), Tree::Simple->ROOT, '... the clones parent is a root');

for my $child ($clone->getAllChildren()) {
    is($child->getParent(), $clone, '... the clones childrens parent should be our clone');
}

isnt($clone, $tree, '... these should be refs');

is($clone->getChild(0)->getNodeValue(), $tree->getChild(0)->getNodeValue(), '... these should be the same value');

# they should both be scalar refs
is(ref($clone->getChild(1)->getNodeValue()), "SCALAR", '... these should be scalar refs');
is(ref($tree->getChild(1)->getNodeValue()), "SCALAR", '... these should be scalar refs');
# but different ones
isnt($clone->getChild(1)->getNodeValue(), $tree->getChild(1)->getNodeValue(), 
	'... these should be different scalar refs');
# with the same value
is(${$clone->getChild(1)->getNodeValue()}, ${$tree->getChild(1)->getNodeValue()}, 
	'... these should be the same value');
	
# they should both be array refs
is(ref($clone->getChild(2)->getNodeValue()), "ARRAY", '... these should be array refs');
is(ref($tree->getChild(2)->getNodeValue()), "ARRAY", '... these should be array refs');
# but different ones
isnt($clone->getChild(2)->getNodeValue(), $tree->getChild(2)->getNodeValue(), 
	'... these should be different array refs');	
# with the same value	
is_deeply(
    $clone->getChild(2)->getNodeValue(), 
    $tree->getChild(2)->getNodeValue(), 
	'... these should have the same contents');
	
# they should both be hash refs
is(ref($clone->getChild(3)->getNodeValue()), "HASH", '... these should be hash refs');
is(ref($tree->getChild(3)->getNodeValue()), "HASH", '... these should be hash refs');
# but different ones
isnt($clone->getChild(3)->getNodeValue(), $tree->getChild(3)->getNodeValue(), 
	'... these should be different hash refs');	
# with the same value	
is_deeply(
    $clone->getChild(3)->getNodeValue(), 
    $tree->getChild(3)->getNodeValue(), 
	'... these should have the same contents');	

# they should both be code refs
is(ref($clone->getChild(4)->getNodeValue()), "CODE", '... these should be code refs');
is(ref($tree->getChild(4)->getNodeValue()), "CODE", '... these should be code refs');
# and still the same
is($clone->getChild(4)->getNodeValue(), $tree->getChild(4)->getNodeValue(), 
	'... these should be the same code refs');	
is($clone->getChild(4)->getNodeValue()->(), $CODE_REF->(), '... this is equal');

# they should both be reg-ex refs
is(ref($clone->getChild(5)->getNodeValue()), "Regexp", '... these should be reg-ex refs');
is(ref($tree->getChild(5)->getNodeValue()), "Regexp", '... these should be reg-ex refs');
# and still the same
is($clone->getChild(5)->getNodeValue(), $tree->getChild(5)->getNodeValue(), 
	'... these should be the same reg-ex refs');	
	
# they should both be misc object refs
is(ref($clone->getChild(6)->getNodeValue()), "Misc", '... these should be misc object refs');
is(ref($tree->getChild(6)->getNodeValue()), "Misc", '... these should be misc object refs');
# and still the same
is($clone->getChild(6)->getNodeValue(), $tree->getChild(6)->getNodeValue(), 
	'... these should be the same misc object refs');	
	
# they should both be Tree::Simple objects
is(ref($clone->getChild(7)->getNodeValue()), "Tree::Simple", '... these should be Tree::Simple');
is(ref($tree->getChild(7)->getNodeValue()), "Tree::Simple", '... these should be Tree::Simple');
# but different ones
isnt($clone->getChild(7)->getNodeValue(), $tree->getChild(7)->getNodeValue(), 
	'... these should be different Tree::Simple objects');	
# with the same value	
is($clone->getChild(7)->getNodeValue()->getNodeValue(), $tree->getChild(7)->getNodeValue()->getNodeValue(), 
	'... these should have the same contents');	
    
# they should both be scalar refs
is(ref($clone->getChild(8)->getNodeValue()), "REF", '... these should be refs of refs');
is(ref($tree->getChild(8)->getNodeValue()), "REF", '... these should be refs of refs');
# but different ones
isnt($clone->getChild(8)->getNodeValue(), $tree->getChild(8)->getNodeValue(), 
	'... these should be different scalar refs');
# with the same ref value
is(${${$clone->getChild(8)->getNodeValue()}}, ${${$tree->getChild(8)->getNodeValue()}}, 
	'... these should be the same value');    

# test cloneShallow

my $shallow_clone = $tree->cloneShallow();

isnt($shallow_clone, $tree, '... these should be refs');

is_deeply(
		[ $shallow_clone->getAllChildren() ],
		[ $tree->getAllChildren() ],
		'... the children are the same');
		
my $sub_tree = $tree->getChild(7);
my $sub_tree_clone = $sub_tree->cloneShallow();
# but different ones
isnt($sub_tree_clone->getNodeValue(), $sub_tree->getNodeValue(), 
	'... these should be different Tree::Simple objects');		
# with the same value	
is($sub_tree_clone->getNodeValue()->getNodeValue(), $sub_tree->getNodeValue()->getNodeValue(), 
	'... these should have the same contents');