File Coverage

blib/lib/Pod/Abstract/Tree.pm

Criterion	Covered	Total	%
statement	32	95	33.6
branch	4	20	20.0
condition	0	3	0.0
subroutine	5	10	50.0
pod	8	9	88.8
total	49	137	35.7

package Pod::Abstract::Tree;
use strict;

our $VERSION = '0.20';

=head1 NAME

Pod::Abstract::Tree - Manage a level of Pod document tree Nodes.

=head1 DESCRIPTION

Pod::Abstract::Tree keeps track of a set of Pod::Abstract::Node
elements, and allows manipulation of that list of elements. Elements
are stored in an ordered set - a single node can appear once only in a
single document tree, so inserting a node at a point will also remove
it from it's previous location.

This is an internal class to Pod::Abstract::Node, and should not
generally be used externally.

=head1 METHODS

=cut

sub new {
    my $class = shift;

    return bless {
        id_map => { },
        nodes => [ ],
    }, $class;
}

=head2 detach

 $tree->detach($node);

Unparent the C<$node> from C<$tree>. All other elements will be
shifted to fill the empty spot.

=cut

sub detach {
    my $self = shift;
    my $node = shift;
    my $id_map = $self->{id_map};
    my $serial = $node->serial;

    my $idx = $id_map->{$node->serial};
    return 0 unless defined $idx;
    die "Wrong node ($idx/$serial)! Got: ", $self->{nodes}[$idx]->serial
        unless $self->{nodes}[$idx]->serial == $serial;

    # Node is defined, remove it:
    splice @{$self->{nodes}},$idx,1;
    delete $id_map->{$serial};

    #  Move all following nodes back by 1
    my $length = scalar @{$self->{nodes}};
    for(my $i = $idx; $i < $length; $i ++) {
        my $s = $self->{nodes}[$i]->serial;
        $id_map->{$s} --;
    }

    # Node now has no parent.
    $node->parent(undef);
    return $node;
}

=head2 push

Add an element to the end of the node list.

=cut

sub push {
    my $self = shift;
    my $node = shift;

    if($node->attached) {
        $node->detach;
        warn "Implicit detach of node on push";
    }

    my $s = $node->serial;
    push @{$self->{nodes}}, $node;
    $self->{id_map}{$s} = $#{$self->{nodes}};
    return 1;
}

=head2 pop

Remove an element from the end of the node list.

=cut

sub pop {
    my $self = shift;

    my $node = pop @{$self->{nodes}};
    my $s = $node->serial;
    delete $self->{id_map}{$s};
    $node->parent(undef);

    return $node;
}

=head2 insert_before

 $tree->insert_before($target,$node);

Insert C<$node> before C<$target>. Both must be children of C<$tree>

=cut

sub insert_before {
    my $self = shift;
    my $target = shift;
    my $node = shift;

    my $idx = $self->{id_map}{$target->serial};
    return 0 unless defined $idx;

    splice(@{$self->{nodes}}, $idx, 0, $node);
    $self->{id_map}{$node->serial} = $idx;

    # Push all following nodes forwards by 1.
    my $length = scalar @{$self->{nodes}};
    for( my $i = $idx + 1; $i < $length; $i ++) {
        my $s = $self->{nodes}[$i]->serial;
        $self->{id_map}{$s} ++;
    }
    return 1;
}

=head2 insert_after

 $tree->insert_after($target,$node);

Insert C<$node> after C<$target>. Both must be children of C<$tree>

=cut

sub insert_after {
    my $self = shift;
    my $target = shift;
    my $node = shift;

    my $idx = $self->{id_map}{$target->serial};
    die $target->serial, " not in index ", join(", ", keys %{$self->{id_map}})
        unless defined $idx;
    my $last_idx = $#{$self->{nodes}};
    if($idx == $last_idx) {
        return $self->push($node);
    } else {
        my $before_target = $self->{nodes}[$idx + 1];
        return $self->insert_before($before_target, $node);
    }
}

=head2 unshift

Remove the first node from the node list and return it.

Unshift takes linear time - it has to relocate every other element in
id_map so that they stay in line.

=cut

sub unshift {
    my $self = shift;
    my $node = shift;

    if($node->attached) {
        $node->detach;
        warn "Implicit detach of node on unshift";
    }

    my $s = $node->serial;
    foreach my $k (keys %{$self->{id_map}}) {
        $self->{id_map}{$k} ++;
    }
    unshift @{$self->{nodes}}, $node;
    $self->{id_map}{$s} = 0;
    return 1;
}

=head2 children

Returns the in-order node list.

=cut

sub children {
    my $self = shift;
    return @{$self->{nodes}};
}

=head2 index_relative

 my $node = $tree->index_relative($target, $offset);

This method will return a node at an offset of $offset (which may be
negative) from this tree structure. If there is no such node, undef
will be returned. For example, an offset of 1 will give the following
element of $node.

=cut

sub index_relative {
    my $self = shift;
    my $node = shift;
    my $index = shift;
    my $serial = $node->serial;

    die "index_relative called with unattached node"
        unless $node->attached;
    my $node_idx = $self->{id_map}{$serial};
    die "index_relative called with node not present in tree"
        unless defined $node_idx;
    my $real_index = $node_idx + $index;
    my $n_nodes = scalar @{$self->{nodes}};
    if($real_index >= 0 && $real_index < $n_nodes) {
        return $self->{nodes}[$real_index];
    } else {
        return undef;
    }
}

=head1 AUTHOR

Ben Lilburne

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 Ben Lilburne

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;