File Coverage

blib/lib/Code/Includable/Tree/NodeMethods.pm

Criterion	Covered	Total	%
statement	164	178	92.1
branch	55	80	68.7
condition	4	5	80.0
subroutine	27	31	87.1
pod	26	26	100.0
total	276	320	86.2

package Code::Includable::Tree::NodeMethods;

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

use strict;
our $IGNORE_NO_CHILDREN_METHOD = 1;

our $GET_PARENT_METHOD = 'parent';
our $GET_CHILDREN_METHOD = 'children';
our $SET_PARENT_METHOD = 'parent';
our $SET_CHILDREN_METHOD = 'children';

# we must contain no other functions

use Scalar::Util ();

# like children, but always return list
sub _children_as_list {
    my $self = shift;
    my @children;
    if ($IGNORE_NO_CHILDREN_METHOD) {
        eval {
            @children = $self->$GET_CHILDREN_METHOD;
        };
        return () if $@;
    } else {
        @children = $self->$GET_CHILDREN_METHOD;
    }

    if (@children == 1) {
        return () unless defined($children[0]);
        return @{$children[0]} if ref($children[0]) eq 'ARRAY';
    }
    @children;
}

# direct children first
sub _descendants {
    my ($self, $res) = @_;
    my @children = _children_as_list($self);
    push @$res, @children;
    for (@children) { _descendants($_, $res) }
}

sub descendants {
    my $self = shift;
    my $res = [];
    _descendants($self, $res);
    @$res;
}

sub _descendants_depth_first {
    my ($self, $res) = @_;
    my @children = _children_as_list($self);
    for (@children) {
        push @$res, $_;
        _descendants_depth_first($_, $res);
    }
}

sub descendants_depth_first {
    my $self = shift;
    my $res = [];
    _descendants_depth_first($self, $res);
    @$res;
}

sub ancestors {
    my $self = shift;
    my @res;
    my $parent = $self->$GET_PARENT_METHOD;
    while ($parent) {
        push @res, $parent;
        $parent = $parent->$GET_PARENT_METHOD;
    }
    @res;
}

sub retrieve_parent {
    my $self = shift;
    $self->$GET_PARENT_METHOD;
}

sub walk {
    my ($self, $code) = @_;
    for (descendants($self)) {
        $code->($_);
    }
}

sub first_node {
    my ($self, $code) = @_;
    for (descendants($self)) {
        return $_ if $code->($_);
    }
    undef;
}

sub is_first_child {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my @siblings = _children_as_list($parent);
    @siblings && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[0]);
}

sub is_last_child {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my @siblings = _children_as_list($parent);
    @siblings && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[-1]);
}

sub is_only_child {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my @siblings = _children_as_list($parent);
    @siblings==1;# && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[0]);
}

sub is_nth_child {
    my ($self, $n) = @_;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my @siblings = _children_as_list($parent);
    @siblings >= $n && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[$n-1]);
}

sub is_nth_last_child {
    my ($self, $n) = @_;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my @siblings = _children_as_list($parent);
    @siblings >= $n && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[-$n]);
}

sub is_first_child_of_type {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my $type = ref($self);
    my @siblings = grep { ref($_) eq $type } _children_as_list($parent);
    @siblings && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[0]);
}

sub is_last_child_of_type {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my $type = ref($self);
    my @siblings = grep { ref($_) eq $type } _children_as_list($parent);
    @siblings && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[-1]);
}

sub is_only_child_of_type {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my $type = ref($self);
    my @siblings = grep { ref($_) eq $type } _children_as_list($parent);
    @siblings == 1; # && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[0]);
}

sub is_nth_child_of_type {
    my ($self, $n) = @_;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my $type = ref($self);
    my @siblings = grep { ref($_) eq $type } _children_as_list($parent);
    @siblings >= $n && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($siblings[$n-1]);
}

sub is_nth_last_child_of_type {
    my ($self, $n) = @_;
    my $parent = $self->$GET_PARENT_METHOD;
    return 0 unless $parent;
    my $type = ref($self);
    my @children = grep { ref($_) eq $type } _children_as_list($parent);
    @children >= $n && Scalar::Util::refaddr($self) == Scalar::Util::refaddr($children[-$n]);
}

sub prev_sibling {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD or return undef;
    my $refaddr = Scalar::Util::refaddr($self);
    my @siblings = _children_as_list($parent);
    for my $i (1..$#siblings) {
        if (Scalar::Util::refaddr($siblings[$i]) == $refaddr) {
            return $siblings[$i-1];
        }
    }
    undef;
}

sub prev_siblings {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD or return ();
    my $refaddr = Scalar::Util::refaddr($self);
    my @siblings = _children_as_list($parent);
    for my $i (1..$#siblings) {
        if (Scalar::Util::refaddr($siblings[$i]) == $refaddr) {
            return @siblings[0..$i-1];
        }
    }
    ();
}

sub next_sibling {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD or return undef;
    my $refaddr = Scalar::Util::refaddr($self);
    my @siblings = _children_as_list($parent);
    for my $i (0..$#siblings-1) {
        if (Scalar::Util::refaddr($siblings[$i]) == $refaddr) {
            return $siblings[$i+1];
        }
    }
    undef;
}

sub next_siblings {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD or return ();
    my $refaddr = Scalar::Util::refaddr($self);
    my @siblings = _children_as_list($parent);
    for my $i (0..$#siblings-1) {
        if (Scalar::Util::refaddr($siblings[$i]) == $refaddr) {
            return @siblings[$i+1 .. $#siblings];
        }
    }
    ();
}

sub is_root {
    my ($self, $n) = @_;
    my $parent = $self->$GET_PARENT_METHOD;
    return $parent ? 0:1;
}

sub has_min_children {
    my ($self, $m) = @_;
    my @children = _children_as_list($self);
    @children >= $m;
}

sub has_max_children {
    my ($self, $n) = @_;
    my @children = _children_as_list($self);
    @children <= $n;
}

sub has_children_between {
    my ($self, $m, $n) = @_;
    my @children = _children_as_list($self);
    @children >= $m && @children <= $n;
}

# remove self from parent
sub remove {
    my $self = shift;
    my $parent = $self->$GET_PARENT_METHOD or return;
    my $refaddr = Scalar::Util::refaddr($self);
    my @remaining_siblings;
    for my $sibling (_children_as_list($parent)) {
        if (Scalar::Util::refaddr($sibling) == $refaddr) {
            $sibling->$SET_PARENT_METHOD(undef);
            next;
        }
        push @remaining_siblings, $sibling;
    }
    $parent->$SET_CHILDREN_METHOD(\@remaining_siblings);
}

# check references
sub check {
    my $self = shift;
    my $opts = shift // {};

    if ($opts->{check_root}) {
        my $parent = $self->$GET_PARENT_METHOD;
        defined $parent and die "check: parent is not undef";
    }

    # check that all children refers back to me in their parent
    my $refaddr = Scalar::Util::refaddr($self);
    my $i = 0;
    for my $child (_children_as_list($self)) {
        my $childs_parent = $child->$GET_PARENT_METHOD;
        unless (defined $childs_parent &&
                    Scalar::Util::refaddr($childs_parent) == $refaddr) {
            die "check: Child #$i of $self does not refer back to its parent";
        }
        check($child, {
            recurse=>1,
            #check_root=>0,
        }) if $opts->{recurse};
    }
}


1;
# ABSTRACT: Tree node routines

__END__