The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Tree::Compat 'Tree::Nary';
use strict;

sub node_build_string() {

	my ($node, $ref_of_arg) = (shift, shift);
	my $p = $ref_of_arg;
	my $string;
	my $c;

	$c = $node->{data};
	if(defined($p)) {
		$string = $$p;
	} else {
		$string = "";
	}

	$string .= $c;
	$$p = $string;
	
	return($Tree::Nary::FALSE);
}

sub test() {

	my $root = Tree::Nary->new("A");
	my $node = Tree::Nary->new();
	my $node_B = Tree::Nary->new("B");
	my $node_F = Tree::Nary->new("F");
	my $node_G = Tree::Nary->new("G");
	my $node_J = Tree::Nary->new("J");
	my $another_root = Tree::Nary->new("Z");

        my $returned_node;
	my $test;
	my $i;
	my $tstring;

	print "not " if(!(Tree::Nary->depth($root) == 1 && Tree::Nary->max_height($root) == 1));
	print "ok 1\n";

	$returned_node = Tree::Nary->append($root, $node_B);
	print "not " if($root->{children} != $node_B);
	print "ok 2\n";

	$returned_node = Tree::Nary->append_data($node_B, "E");
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'E'));
	print "ok 3\n";

	$returned_node = Tree::Nary->prepend_data($node_B, "C");
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'C'));
	print "ok 4\n";

	$returned_node = Tree::Nary->insert($node_B, 1, Tree::Nary->new("D"));
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'D'));
	print "ok 5\n";

	$returned_node = Tree::Nary->append($root, $node_F);
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'F'));
	print "ok 6\n";

	print "not " if($root->{children}->{next} != $node_F);
	print "ok 7\n";

	$returned_node = Tree::Nary->append($node_F, $node_G);
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'G'));
	print "ok 8\n";

	$returned_node = Tree::Nary->prepend($node_G, $node_J);
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'J'));
	print "ok 9\n";

	$returned_node = Tree::Nary->insert($node_G, 42, Tree::Nary->new("K"));
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'K'));
	print "ok 10\n";

	$returned_node = Tree::Nary->insert_data($node_G, 0, "H");
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'H'));
	print "ok 11\n";

	$returned_node = Tree::Nary->insert($node_G, 1, Tree::Nary->new("I"));
        print "not " if (!defined($returned_node) || ($returned_node->{'data'} ne 'I'));
	print "ok 12\n";

	print "not " if(Tree::Nary->depth($root) != 1);
	print "ok 13\n";

	print "not " if(Tree::Nary->max_height($root) != 4);
	print "ok 14\n";

	print "not " if(Tree::Nary->depth($node_G->{children}->{next}) != 4);
	print "ok 15\n";

	print "not " if(Tree::Nary->n_nodes($root, $Tree::Nary::TRAVERSE_LEAFS) != 7);
	print "ok 16\n";

	print "not " if(Tree::Nary->n_nodes($root, $Tree::Nary::TRAVERSE_NON_LEAFS) != 4);
	print "ok 17\n";

	print "not " if(Tree::Nary->n_nodes($root, $Tree::Nary::TRAVERSE_ALL) != 11);
	print "ok 18\n";

	print "not " if(Tree::Nary->max_height($node_F) != 3);
	print "ok 19\n";

	print "not " if(Tree::Nary->n_children($node_G) != 4);
	print "ok 20\n";

	# Find tests
	print "not " if(Tree::Nary->find_child($root, $Tree::Nary::TRAVERSE_ALL, "F") != $node_F);
	print "ok 21\n";

	print "not " if(defined(Tree::Nary->find($root, $Tree::Nary::LEVEL_ORDER, $Tree::Nary::TRAVERSE_NON_LEAFS, "I")));
	print "ok 22\n";

	print "not " if(Tree::Nary->find($root, $Tree::Nary::IN_ORDER, $Tree::Nary::TRAVERSE_LEAFS, "J") != $node_J);
	print "ok 23\n";

	for($i = 0; $i < Tree::Nary->n_children($node_B); $i++) {
		$node = Tree::Nary->nth_child($node_B, $i);
	}

	$test = $Tree::Nary::TRUE;
	for($i = 0; $i < Tree::Nary->n_children($node_G); $i++) {
		if(Tree::Nary->child_position($node_G, Tree::Nary->nth_child($node_G, $i)) == $i) {
			$test &= $Tree::Nary::TRUE;
		} else {
			$test &= $Tree::Nary::FALSE;
		}
	}

	if(!$test) {
		print "not ";
	}
	print "ok 24\n";

	#     We have built:                    A
	#                                     /   \
	#                                   B       F
	#                                 / | \       \
	#                               C   D   E       G
	#                                             / /\ \
	#                                           H  I  J  K
	#    
	#     For in-order traversal, 'G' is considered to be the "left" child
	#     of 'F', which will cause 'F' to be the last node visited.

	$tstring = undef;

	# Next test should be TRUE
	if(!Tree::Nary->is_ancestor($node_F, $node_G)) {
		print "not ";
	}
	print "ok 25\n";

	# Next test should be FALSE
	if(Tree::Nary->is_ancestor($node_G, $node_F)) {
		print "not ";
	}
	print "ok 26\n";

	Tree::Nary->traverse($root, $Tree::Nary::PRE_ORDER, $Tree::Nary::TRAVERSE_ALL, -1, \&node_build_string, \$tstring);

	print "not " if($tstring !~ /ABCDEFGHIJK/);
	print "ok 27\n";

	$tstring = undef;
	Tree::Nary->traverse($root, $Tree::Nary::POST_ORDER, $Tree::Nary::TRAVERSE_ALL, -1, \&node_build_string, \$tstring);

	print "not " if($tstring !~ /CDEBHIJKGFA/);
	print "ok 28\n";

	$tstring = undef;
	Tree::Nary->traverse($root, $Tree::Nary::IN_ORDER, $Tree::Nary::TRAVERSE_ALL, -1, \&node_build_string, \$tstring);

	print "not " if($tstring !~ /CBDEAHGIJKF/);
	print "ok 29\n";

	$tstring = undef;
	Tree::Nary->traverse($root, $Tree::Nary::LEVEL_ORDER, $Tree::Nary::TRAVERSE_ALL, -1, \&node_build_string, \$tstring);

	print "not " if($tstring !~ /ABFCDEGHIJK/);
	print "ok 30\n";

	$tstring = undef;
	Tree::Nary->traverse($root, $Tree::Nary::LEVEL_ORDER, $Tree::Nary::TRAVERSE_LEAFS, -1, \&node_build_string, \$tstring);

	print "not " if($tstring !~ /CDEHIJK/);
	print "ok 31\n";

	$tstring = undef;
	Tree::Nary->traverse($root, $Tree::Nary::PRE_ORDER, $Tree::Nary::TRAVERSE_NON_LEAFS, -1, \&node_build_string, \$tstring);

	print "not " if($tstring !~ /ABFG/);
	print "ok 32\n";

	$tstring = undef;

	Tree::Nary->reverse_children($node_B);
	Tree::Nary->reverse_children($node_G);
	Tree::Nary->traverse($root, $Tree::Nary::LEVEL_ORDER, $Tree::Nary::TRAVERSE_ALL, -1, \&node_build_string, \$tstring);

	print "not " if($tstring !~ /ABFEDCGKJIH/);
	print "ok 33\n";

	# Sort test
	$tstring = undef;

	Tree::Nary->tsort($root);
	Tree::Nary->traverse($root, $Tree::Nary::LEVEL_ORDER, $Tree::Nary::TRAVERSE_ALL, -1, \&node_build_string, \$tstring);
	print "not " if($tstring !~ /ABFCDEGHIJK/);
	print "ok 34\n";

	# Comparison tests
	$returned_node = Tree::Nary->append_data($another_root, "W");

	Tree::Nary->append_data($returned_node, "X");
	Tree::Nary->append_data($returned_node, "A");
	Tree::Nary->append_data($returned_node, "Q");
	Tree::Nary->append_data($returned_node, "S");

	#     We have built:                 Z
	#                                    \
	#                                     W
	#                                   / /\ \
	#                                  X A  Q S

	print "not " if(!Tree::Nary->has_same_struct($node_F, $another_root));
	print "ok 35\n";

	$another_root->{data}= "F";
	$returned_node->{data}= "G";
	Tree::Nary->first_child($returned_node)->{data} = "H";
	Tree::Nary->first_child($returned_node)->{next}->{data} = "I";
	Tree::Nary->last_child($returned_node)->{prev}->{data} = "J";
	Tree::Nary->last_child($returned_node)->{data} = "K";

	print "not " if(!Tree::Nary->is_identical($node_F, $another_root));
	print "ok 36\n";

	# Tree::Nary->DESTROY($root);
}

print "1..36\n";

&test();