File Coverage

blib/lib/Tree.pm

Criterion	Covered	Total	%
statement	177	205	86.3
branch	42	52	80.7
condition	18	24	75.0
subroutine	31	35	88.5
pod	21	21	100.0
total	289	337	85.7

package Tree;

use 5.006;

use base 'Tree::Fast';
use strict;
use warnings;

our $VERSION = '1.16';

use Scalar::Util qw( blessed refaddr weaken );

# These are the class methods

my %error_handlers = (
    'quiet' => sub {
        my $node = shift;
        $node->last_error( join "\n", @_);
        return;
    },
    'warn' => sub {
        my $node = shift;
        $node->last_error( join "\n", @_);
        warn @_;
        return;
    },
    'die' => sub {
        my $node = shift;
        $node->last_error( join "\n", @_);
        die @_;
    },
);

sub QUIET { return $error_handlers{ 'quiet' } }
sub WARN  { return $error_handlers{ 'warn' } }
sub DIE   { return $error_handlers{ 'die' } }

# The default error handler is quiet
my $ERROR_HANDLER = $error_handlers{ 'quiet' };

sub _init {
    my $self = shift;

    $self->SUPER::_init( @_ );

    $self->{_height} = 1,
    $self->{_width} = 1,
    $self->{_depth} = 0,

    $self->{_error_handler} = $ERROR_HANDLER,
    $self->{_last_error} = undef;

    $self->{_handlers} = {
        add_child    => [],
        remove_child => [],
        value        => [],
    };

    $self->{_root} = undef,
    $self->_set_root( $self );

    return $self;
}

# These are the behaviors

sub add_child {
    my $self = shift;
    my @nodes = @_;

    $self->last_error( undef );

    my $options = $self->_strip_options( \@nodes );

    unless ( @nodes ) {
        return $self->error( "add_child(): No children passed in" );
    }

    if ( defined $options->{at}) {
        my $num_children = () = $self->children;
        unless ( $options->{at} =~ /^-?\d+$/ ) {
            return $self->error(
                "add_child(): '$options->{at}' is not a legal index"
            );
        }

        if ( $options->{at} > $num_children ||
                $num_children + $options->{at} < 0
        ) {
            return $self->error( "add_child(): '$options->{at}' is out-of-bounds" );
        }
    }

    for my $node ( @nodes ) {
        unless ( blessed($node) && $node->isa( __PACKAGE__ ) ) {
            return $self->error( "add_child(): '$node' is not a " . __PACKAGE__ );
        }

        if ( $node->root eq $self->root ) {
            return $self->error( "add_child(): Cannot add a node in the tree back into the tree" );
        }

        if ( $node->parent ) {
            return $self->error( "add_child(): Cannot add a child to another parent" );
        }
    }

    $self->SUPER::add_child( $options, @nodes );

    for my $node ( @nodes ) {
        $node->_set_root( $self->root );
        $node->_fix_depth;
    }

    $self->_fix_height;
    $self->_fix_width;

    $self->event( 'add_child', $self, @_ );

    return $self;
}

sub remove_child {
    my $self = shift;
    my @nodes = @_;

    $self->last_error( undef );

    my $options = $self->_strip_options( \@nodes );

    unless ( @nodes ) {
        return $self->error( "remove_child(): Nothing to remove" );
    }

    my @indices;
    my $num_children = () = $self->children;
    foreach my $proto (@nodes) {
        if ( !defined( $proto ) ) {
            return $self->error( "remove_child(): 'undef' is out-of-bounds" );
        }

        if ( !blessed( $proto ) ) {
            unless ( $proto =~ /^-?\d+$/ ) {
                return $self->error( "remove_child(): '$proto' is not a legal index" );
            }

            if ( $proto >= $num_children || $num_children + $proto <= 0 ) {
                return $self->error( "remove_child(): '$proto' is out-of-bounds" );
            }

            push @indices, $proto;
        }
        else {
            my ($index) = $self->get_index_for( $proto );

            unless ( defined $index ) {
                return $self->error( "remove_child(): '$proto' not found" );
            }

            push @indices, $index;
        }
    }

    my @return = $self->SUPER::remove_child( $options, @indices );

    for my $node ( @return ) {
        $node->_set_root( $node );
        $node->_fix_depth;
    }

    $self->_fix_height;
    $self->_fix_width;

    $self->event( 'remove_child', $self, @_ );

    return @return;
}

sub add_event_handler {
    my $self = shift;
    my ($opts) = @_;

    while ( my ($type,$handler) = each %$opts ) {
        push @{$self->{_handlers}{$type}}, $handler;
    }

    return $self;
}

sub event {
    my $self = shift;
    my ( $type, @args ) = @_;

    foreach my $handler ( @{$self->{_handlers}{$type}} ) {
        $handler->( @args );
    }

    $self->parent->event( @_ );

    return $self;
}

# These are the state-queries

sub is_root {
    my $self = shift;
    return !$self->parent;
}

sub is_leaf {
    my $self = shift;
    return $self->height == 1;
}

sub has_child {
    my $self = shift;
    my @nodes = @_;

    my @children = $self->children;
    my %temp = map { refaddr($children[$_]) => $_ } 0 .. $#children;

    my $rv = 1;
    $rv &&= exists $temp{refaddr($_)}
        for @nodes;
    return $rv;
}

sub get_index_for {
    my $self = shift;
    my @nodes = @_;

    my @children = $self->children;
    my %temp = map { refaddr($children[$_]) => $_ } 0 .. $#children;

    return map { $temp{refaddr($_)} } @nodes;
}

# These are the smart accessors

sub root {
    my $self = shift;
    return $self->{_root};
}

sub _set_root {
    my $self = shift;

    $self->{_root} = shift;
    weaken( $self->{_root} );

    # Propagate the root-change down to all children
    # Because this is called from DESTROY, we need to verify
    # that the child still exists because destruction in Perl5
    # is neither ordered nor timely.

    $_->_set_root( $self->{_root} )
        for grep { $_ } @{$self->{_children}};

    return $self;
}

for my $name ( qw( height width depth ) ) {
    no strict 'refs';

    *{ __PACKAGE__ . "::${name}" } = sub {
        use strict;
        my $self = shift;
        return $self->{"_${name}"};
    };
}

sub size {
    my $self = shift;
    my $size = 1;
    $size += $_->size for $self->children;
    return $size;
}

sub set_value {
    my $self = shift;

    my $old_value = $self->value();
    $self->SUPER::set_value( @_ );

    $self->event( 'value', $self, $old_value, $self->value );

    return $self;
}

# These are the error-handling functions

sub error_handler {
    my $self = shift;

    if ( !blessed( $self ) ) {
        my $old = $ERROR_HANDLER;
        $ERROR_HANDLER = shift if @_;
        return $old;
    }

    my $root = $self->root;
    my $old = $root->{_error_handler};
    $root->{_error_handler} = shift if @_;
    return $old;
}

sub error {
    my $self = shift;
    my @args = @_;

    return $self->error_handler->( $self, @_ );
}

sub last_error {
    my $self = shift;
    $self->root->{_last_error} = shift if @_;
    return $self->root->{_last_error};
}

# These are private convenience methods

sub _fix_height {
    my $self = shift;

    my $height = 1;
    for my $child ($self->children) {
        my $temp_height = $child->height + 1;
        $height = $temp_height if $height < $temp_height;
    }

    $self->{_height} = $height;

    $self->parent->_fix_height;

    return $self;
}

sub _fix_width {
    my $self = shift;

    my $width = 0;
    $width += $_->width for $self->children;

    $self->{_width} = $width ? $width : 1;

    $self->parent->_fix_width;

    return $self;
}

sub _fix_depth {
    my $self = shift;

    if ( $self->is_root ) {
        $self->{_depth} = 0;
    }
    else {
        $self->{_depth} = $self->parent->depth + 1;
    }

    $_->_fix_depth for $self->children;

    return $self;
}

sub _strip_options {
    my $self = shift;
    my ($params) = @_;

    if ( @$params && !blessed($params->[0]) && ref($params->[0]) eq 'HASH' ) {
        return shift @$params;
    }
    else {
        return {};
    }
}

# -----------------------------------------------

sub format_node
{
	my($self, $options, $node) = @_;
	my($s) = $node -> value;
	$s     .= '. Attributes: ' . $self -> hashref2string($node -> meta) if (! $$options{no_attributes});

	return $s;

} # End of format_node.

# -----------------------------------------------

sub hashref2string
{
	my($self, $hashref) = @_;
	$hashref ||= {};

	return '{' . join(', ', map{qq|$_ => "$$hashref{$_}"|} sort keys %$hashref) . '}';

} # End of hashref2string.

# -----------------------------------------------

sub node2string
{
	my($self, $options, $node, $vert_dashes) = @_;
	my($depth)         = $node -> depth;
	my(@siblings)      = $node -> parent -> children;
	my($sibling_count) = scalar @siblings; # Warning: Don't combine this with the previous line.
	my($offset)        = ' ' x 4;
	my(@indent)        = map{$$vert_dashes[$_] || $offset} 0 .. $depth - 1;
	@$vert_dashes      =
	(
		@indent,
		($sibling_count == 0 ? $offset : '    |'),
	);

	my(@i)                = $node -> parent -> get_index_for($node);
	my(@indexes)          = $node -> parent -> get_index_for($node);
	$$vert_dashes[$depth] = ($offset . ' ') if ($sibling_count == ($indexes[0] + 1) );

	return join('', @indent[1 .. $#indent]) . ($depth ? '    |--- ' : '') . $self -> format_node($options, $node);

} # End of node2string.

# ------------------------------------------------

sub tree2string
{
	my($self, $options)      = @_;
	$options                 ||= {};
	$$options{no_attributes} ||= 0;
	my(@nodes)               = $self -> traverse;

	my(@out);
	my(@vert_dashes);

	for my $i (0 .. $#nodes)
	{
		push @out, $self -> node2string($options, $nodes[$i], \@vert_dashes);
	}

	return [@out];

} # End of tree2string.

# -----------------------------------------------

1;
__END__