File Coverage

blib/lib/Test/Role/TinyCommons/Tree.pm

Criterion	Covered	Total	%
statement	258	258	100.0
branch	9	16	56.2
condition	6	13	46.1
subroutine	9	9	100.0
pod	1	1	100.0
total	283	297	95.2

package Test::Role::TinyCommons::Tree;

use strict;
use warnings;
use Test::Exception;
use Test::More 0.98;

use Exporter qw(import);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-10-07'; # DATE
our $DIST = 'Role-TinyCommons-Tree'; # DIST
our $VERSION = '0.128'; # VERSION

our @EXPORT_OK = qw(test_role_tinycommons_tree);

sub test_role_tinycommons_tree {
    my %args = @_;

    my $c  = $args{class};
    my $c1 = $args{subclass1};
    my $c2 = $args{subclass2};

    my $a1 = $args{attribute1} || 'id';

    my $m  = $args{constructor_name} || 'new';

    subtest "Tree::Node" => sub {
        my $pnode  = $c->new;
        my $mode1 = $c->new;
        my $mode2 = $c->new;
        lives_ok {
            $mode1->parent($pnode);
            $mode2->parent($pnode);
            $pnode->children([$mode1, $mode2]);
        } "set parent & children";
        is_deeply($mode1->parent, $pnode, "get parent (1)");
        is_deeply($mode2->parent, $pnode, "get parent (1)");
        my @children = $pnode->children;
        @children = @{$children[0]}
            if @children==1 && ref($children[0]) eq 'ARRAY';
        is_deeply(\@children, [$mode1, $mode2], "get children");
    };

    subtest "Tree::FromStruct" => sub {
        my $tree;

        my $struct = {
            ( _instantiate => $args{code_instantiate} ) x
                !!$args{code_instantiate},
            _pass_attributes => 0,
            _constructor => $m,

            $a1 => 0, _children => [
                {$a1 => 1, _children => [
                    {$a1 => 3},
                    {$a1 => 4, _class=>$c2},
                    {$a1 => 5, _class=>$c2},
                    {$a1 => 6, _class=>$c1},
                    {$a1 => 7},
                ]},
                {$a1 => 2, _children => [
                    {$a1 => 8, _class => $c2, _children => [
                        {$a1 => 9, _class => $c1},
                    ]},
                ]},
            ],
        };

        $tree = $c->new_from_struct($struct);

        my $exp_tree = do {
            my $n0 = $c ->$m; $n0->$a1(0);

            my $n1 = $c ->$m; $n1->$a1(1); $n1->parent($n0);
            my $n2 = $c ->$m; $n2->$a1(2); $n2->parent($n0);
            $n0->children([$n1, $n2]);

            my $n3 = $c ->$m; $n3->$a1(3); $n3->parent($n1);
            my $n4 = $c2->$m; $n4->$a1(4); $n4->parent($n1);
            my $n5 = $c2->$m; $n5->$a1(5); $n5->parent($n1);
            my $n6 = $c1->$m; $n6->$a1(6); $n6->parent($n1);
            my $n7 = $c ->$m; $n7->$a1(7); $n7->parent($n1);
            $n1->children([$n3, $n4, $n5, $n6, $n7]);

            my $n8 = $c2->$m; $n8->$a1(8); $n8->parent($n2);
            $n2->children([$n8]);

            my $n9 = $c1->$m; $n9->$a1(9); $n9->parent($n8);
            $n8->children([$n9]);

            $n0;
        };

        is_deeply($tree, $exp_tree, "result") or diag explain $tree;

        $tree =
            Code::Includable::Tree::FromStruct::new_from_struct($c, $struct);

        is_deeply($tree, $exp_tree, "result (sub call)");

    } if $args{test_fromstruct};

    subtest "Tree::NodeMethods" => sub {
        my ($n0, $n1, $n2, $n3, $n4, $n5, $n6, $n7, $n8, $n9);

      BUILD:
        {
            $n0 = $c ->$m; $n0->$a1(0);

            $n1 = $c ->$m; $n1->$a1(1); $n1->parent($n0);
            $n2 = $c ->$m; $n2->$a1(2); $n2->parent($n0);
            $n0->children([$n1, $n2]);

            $n3 = $c ->$m; $n3->$a1(3); $n3->parent($n1);
            $n4 = $c2->$m; $n4->$a1(4); $n4->parent($n1);
            $n5 = $c2->$m; $n5->$a1(5); $n5->parent($n1);
            $n6 = $c1->$m; $n6->$a1(6); $n6->parent($n1);
            $n7 = $c ->$m; $n7->$a1(7); $n7->parent($n1);
            $n1->children([$n3, $n4, $n5, $n6, $n7]);

            $n8 = $c2->$m; $n8->$a1(8); $n8->parent($n2);
            $n2->children([$n8]);

            $n9 = $c1->$m; $n9->$a1(9); $n9->parent($n8);
            $n8->children([$n9]);

            # structure:
            # 0 (c)
            #   1 (c)
            #     3 (c)
            #     4 (c2)
            #     5 (c2)
            #     6 (c1)
            #     7 (c)
            #   2 (c)
            #     8 (c2)
            #       9 (c1)
        }

        is_deeply([$n9->ancestors],
                  [$n8, $n2, $n0],
                  "ancestors (1)");
        is_deeply([Code::Includable::Tree::NodeMethods::ancestors($n9)],
                  [$n8, $n2, $n0],
                  "ancestors (1) (sub call)");
        is_deeply([$n0->ancestors],
                  [],
                  "ancestors (2)");
        is_deeply([Code::Includable::Tree::NodeMethods::ancestors($n0)],
                  [],
                  "ancestors (2) (sub call)");

        is_deeply([$n9->retrieve_parent],
                  [$n8],
                  "retrieve_parent (1)");
        ok( $n1->retrieve_parent, "retrieve_parent [1]");
        # XXX more

        is_deeply([$n0->descendants],
                  [$n1, $n2, $n3, $n4, $n5, $n6, $n7, $n8, $n9],
                  "descendants");
        is_deeply([Code::Includable::Tree::NodeMethods::descendants($n0)],
                  [$n1, $n2, $n3, $n4, $n5, $n6, $n7, $n8, $n9],
                  "descendants (sub call)");

        is_deeply([$n0->descendants_depth_first],
                  [$n1, $n3, $n4, $n5, $n6, $n7, $n2, $n8, $n9],
                  "descendants_depth_first");
        is_deeply([Code::Includable::Tree::NodeMethods::descendants_depth_first($n0)],
                  [$n1, $n3, $n4, $n5, $n6, $n7, $n2, $n8, $n9],
                  "descendants_depth_first (sub call)");

        # XXX test walk

        is_deeply($n0->first_node(sub { $_[0]->id == 5 }),
                  $n5, "first_node");
        is_deeply(Code::Includable::Tree::NodeMethods::first_node($n0, sub { $_[0]->id == 5 }),
                  $n5, "first_node (sub call)");

        ok( $n1->is_first_child, "is_first_child [1]");
        ok(!$n2->is_first_child, "is_first_child [2]");
        ok(!$n0->is_first_child, "is_first_child [3]");
        ok( Code::Includable::Tree::NodeMethods::is_first_child($n1), "is_first_child [1] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_first_child($n2), "is_first_child [2] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_first_child($n0), "is_first_child [3] (sub call)");

        ok(!$n1->is_last_child, "is_last_child [1]");
        ok( $n2->is_last_child, "is_last_child [2]");
        ok(!$n0->is_last_child, "is_last_child [3]");
        ok(!Code::Includable::Tree::NodeMethods::is_last_child($n1), "is_last_child [1] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_last_child($n2), "is_last_child [2] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_last_child($n0), "is_last_child [3] (sub call)");

        ok(!$n1->is_only_child, "is_only_child [1]");
        ok( $n8->is_only_child, "is_only_child [2]");
        ok(!$n0->is_only_child, "is_only_child [3]");
        ok(!Code::Includable::Tree::NodeMethods::is_only_child($n1), "is_only_child [1] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_only_child($n8), "is_only_child [2] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_only_child($n0), "is_only_child [3] (sub call)");

        ok( $n1 ->is_nth_child(1), "is_nth_child [1]");
        ok(!$n1 ->is_nth_child(2), "is_nth_child [2]");
        ok( $n2 ->is_nth_child(2), "is_nth_child [3]");
        ok( Code::Includable::Tree::NodeMethods::is_nth_child($n1, 1), "is_nth_child [1] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_nth_child($n1, 2), "is_nth_child [2] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_nth_child($n2, 2), "is_nth_child [3] (sub call)");

        ok(!$n1 ->is_nth_last_child(1), "is_nth_last_child [1]");
        ok( $n1 ->is_nth_last_child(2), "is_nth_last_child [2]");
        ok(!$n2 ->is_nth_last_child(2), "is_nth_last_child [3]");
        ok(!Code::Includable::Tree::NodeMethods::is_nth_last_child($n1, 1), "is_nth_last_child [1] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_nth_last_child($n1, 2), "is_nth_last_child [2] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_nth_last_child($n2, 2), "is_nth_last_child [3] (sub call)");

        ok( $n3 ->is_first_child_of_type, "is_first_child_of_type [1]");
        ok( $n4 ->is_first_child_of_type, "is_first_child_of_type [2]");
        ok(!$n5 ->is_first_child_of_type, "is_first_child_of_type [3]");
        ok( $n6 ->is_first_child_of_type, "is_first_child_of_type [4]");
        ok(!$n7 ->is_first_child_of_type, "is_first_child_of_type [4]");
        ok( Code::Includable::Tree::NodeMethods::is_first_child_of_type($n3), "is_first_child_of_type [1] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_first_child_of_type($n4), "is_first_child_of_type [2] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_first_child_of_type($n5), "is_first_child_of_type [3] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_first_child_of_type($n6), "is_first_child_of_type [4] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_first_child_of_type($n7), "is_first_child_of_type [4] (sub call)");

        ok(!$n3 ->is_last_child_of_type, "is_last_child_of_type [1]");
        ok(!$n4 ->is_last_child_of_type, "is_last_child_of_type [2]");
        ok( $n5 ->is_last_child_of_type, "is_last_child_of_type [3]");
        ok( $n6 ->is_last_child_of_type, "is_last_child_of_type [4]");
        ok( $n7 ->is_last_child_of_type, "is_last_child_of_type [5]");
        ok(!Code::Includable::Tree::NodeMethods::is_last_child_of_type($n3), "is_last_child_of_type [1] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_last_child_of_type($n4), "is_last_child_of_type [2] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_last_child_of_type($n5), "is_last_child_of_type [3] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_last_child_of_type($n6), "is_last_child_of_type [4] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_last_child_of_type($n7), "is_last_child_of_type [5] (sub call)");

        ok(!$n3 ->is_last_child_of_type, "is_last_child_of_type [1]");
        ok(!$n4 ->is_last_child_of_type, "is_last_child_of_type [2]");
        ok( $n5 ->is_last_child_of_type, "is_last_child_of_type [3]");
        ok( $n6 ->is_last_child_of_type, "is_last_child_of_type [4]");
        ok( $n7 ->is_last_child_of_type, "is_last_child_of_type [5]");
        ok(!Code::Includable::Tree::NodeMethods::is_last_child_of_type($n3), "is_last_child_of_type [1] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_last_child_of_type($n4), "is_last_child_of_type [2] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_last_child_of_type($n5), "is_last_child_of_type [3] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_last_child_of_type($n6), "is_last_child_of_type [4] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_last_child_of_type($n7), "is_last_child_of_type [5] (sub call)");

        ok( $n3 ->is_nth_child_of_type(1), "is_nth_child_of_type [1]");
        ok(!$n3 ->is_nth_child_of_type(2), "is_nth_child_of_type [2]");
        ok( $n4 ->is_nth_child_of_type(1), "is_nth_child_of_type [3]");
        ok(!$n4 ->is_nth_child_of_type(2), "is_nth_child_of_type [4]");
        ok( Code::Includable::Tree::NodeMethods::is_nth_child_of_type($n3, 1), "is_nth_child_of_type [1] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_nth_child_of_type($n3, 2), "is_nth_child_of_type [2] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_nth_child_of_type($n4, 1), "is_nth_child_of_type [3] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_nth_child_of_type($n4, 2), "is_nth_child_of_type [4] (sub call)");

        ok(!$n3 ->is_nth_last_child_of_type(1), "is_nth_last_child_of_type [1]");
        ok( $n3 ->is_nth_last_child_of_type(2), "is_nth_last_child_of_type [2]");
        ok(!$n4 ->is_nth_last_child_of_type(1), "is_nth_last_child_of_type [3]");
        ok( $n4 ->is_nth_last_child_of_type(2), "is_nth_last_child_of_type [4]");
        ok(!Code::Includable::Tree::NodeMethods::is_nth_last_child_of_type($n3, 1), "is_nth_last_child_of_type [1] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_nth_last_child_of_type($n3, 2), "is_nth_last_child_of_type [2] (sub call)");
        ok(!Code::Includable::Tree::NodeMethods::is_nth_last_child_of_type($n4, 1), "is_nth_last_child_of_type [3] (sub call)");
        ok( Code::Includable::Tree::NodeMethods::is_nth_last_child_of_type($n4, 2), "is_nth_last_child_of_type [4] (sub call)");

        ok(!$n3 ->is_only_child_of_type, "is_only_child_of_type [1]");
        ok( $n6 ->is_only_child_of_type, "is_only_child_of_type [2]");
        ok(!Code::Includable::Tree::NodeMethods::is_only_child_of_type($n3), "is_only_child_of_type [1]");
        ok( Code::Includable::Tree::NodeMethods::is_only_child_of_type($n6), "is_only_child_of_type [2]");

        is_deeply($n3->prev_sibling, undef, "prev_sibling [1]");
        is_deeply($n5->prev_sibling, $n4  , "prev_sibling [2]");
        is_deeply($n7->prev_sibling, $n6  , "prev_sibling [3]");
        is_deeply(Code::Includable::Tree::NodeMethods::prev_sibling($n3), undef, "prev_sibling [1] (sub call)");
        is_deeply(Code::Includable::Tree::NodeMethods::prev_sibling($n5), $n4  , "prev_sibling [2] (sub call)");
        is_deeply(Code::Includable::Tree::NodeMethods::prev_sibling($n7), $n6  , "prev_sibling [3] (sub call)");

        is_deeply($n3->next_sibling, $n4  , "next_sibling [1]");
        is_deeply($n5->next_sibling, $n6  , "next_sibling [2]");
        is_deeply($n7->next_sibling, undef, "next_sibling [3]");
        is_deeply(Code::Includable::Tree::NodeMethods::next_sibling($n3), $n4  , "next_sibling [1] (sub call)");
        is_deeply(Code::Includable::Tree::NodeMethods::next_sibling($n5), $n6  , "next_sibling [2] (sub call)");
        is_deeply(Code::Includable::Tree::NodeMethods::next_sibling($n7), undef, "next_sibling [3] (sub call)");

        is_deeply([$n3->prev_siblings], []        , "prev_siblings [1] (sub call)");
        is_deeply([$n5->prev_siblings], [$n3, $n4], "prev_siblings [2] (sub call)");
        is_deeply([Code::Includable::Tree::NodeMethods::prev_siblings($n3)], []        , "prev_siblings [1] (sub call)");
        is_deeply([Code::Includable::Tree::NodeMethods::prev_siblings($n5)], [$n3, $n4], "prev_siblings [2] (sub call)");

        is_deeply([$n5->next_siblings], [$n6, $n7], "next_siblings [1] (sub call)");
        is_deeply([$n7->next_siblings], []        , "next_siblings [2] (sub call)");
        is_deeply([Code::Includable::Tree::NodeMethods::next_siblings($n5)], [$n6, $n7], "next_siblings [1] (sub call)");
        is_deeply([Code::Includable::Tree::NodeMethods::next_siblings($n7)], []        , "next_siblings [2] (sub call)");

        ok( $n0->is_root, "is_root [0]");
        ok(!$n1->is_root, "is_root [1]");

        # check
        {
            lives_ok { $n0->check({check_root=>1}) };

            $n3->parent($n2);
            lives_ok { $n0->check };
            dies_ok { $n1->check };
            dies_ok { $n1->check({recurse=>1}) };
            $n3->parent($n1);

            # opt:check_root=1
            $n0->parent($n0);
            dies_ok { $n0->check({check_root => 1}) };
            $n0->parent(undef);
        }

        # remove
        {
            my @children;

            Code::Includable::Tree::NodeMethods::remove($n8);
            @children = $n2->children;
            if (@children == 1 && ref $children[0] eq 'ARRAY') { @children = @{ $children[0] } }
            is_deeply(\@children, [])
                or diag explain \@children;

            Code::Includable::Tree::NodeMethods::remove($n6);
            @children = $n1->children;
            if (@children == 1 && ref $children[0] eq 'ARRAY') { @children = @{ $children[0] } }
            is_deeply(\@children, [$n3, $n4, $n5, $n7])
                or diag explain \@children;
        }

    } if $args{test_nodemethods};
}

1;
# ABSTRACT: Test suite for Role::TinyCommons::Tree

__END__