File Coverage

blib/lib/DBIx/Tree/MaterializedPath/TreeRepresentation.pm

Criterion	Covered	Total	%
statement	106	107	99.0
branch	38	40	95.0
condition	1	3	33.3
subroutine	12	12	100.0
pod	4	4	100.0
total	161	166	96.9

package DBIx::Tree::MaterializedPath::TreeRepresentation;

use warnings;
use strict;

use Carp;

use Readonly;

use DBIx::Tree::MaterializedPath::Node;

=head1 NAME

DBIx::Tree::MaterializedPath::TreeRepresentation - data structure for "materialized path" trees

=head1 VERSION

Version 0.06

=cut

use version 0.74; our $VERSION = qv('0.06');

=head1 SYNOPSIS

    # Row data must be sorted by path:
    my $column_names = ['id', 'path', 'name'];
    my $subtree_data = [
                        [ 2, "1.1",     "a"],
                        [ 3, "1.2",     "b"],
                        [ 4, "1.3",     "c"],
                        [ 5, "1.3.1",   "d"],
                        [ 7, "1.3.1.1", "e"],
                        [ 6, "1.3.2",   "f"],
                       ];

    my $subtree_representation =
      DBIx::Tree::MaterializedPath::TreeRepresentation->new($node,
                                                            $column_names,
                                                            $subtree_data);

    $subtree_representation->traverse($coderef, $context);

=head1 DESCRIPTION

This module implements a data structure that represents a tree
(or subtree) as stored in the database.

B Normally these objects would not be created independently
- call
L
on a
L
or a
L
to get its descendants as a
L
object, and then
L
those descendants.

=head1 METHODS

=head2 new

    $subtree_data =
      DBIx::Tree::MaterializedPath::TreeRepresentation->new($node,
                                                            $cols_listref,
                                                            $rows_listref,
                                                            $options_hashref);

C expects a
L
object (representing the node that this data belongs to), a listref
of database column names, and a listref of listrefs, each of which
represents a node row in the database.

At minimum, each row must contain entries for the
L
and the
L
as specified in the
L
constructor.  The rows should be sorted by path in ascending order.

Additionally, the row may contain entries for
any metadata columns which are stored with the nodes.

One L object will be created in
the data structure for each input row.  If the optional parameters
hashref contains a true value for "B", and if no
metadata entries exist in the input row, then the node object's
metadata will not be populated, and will only be retrieved
from the database when the L method is called on a
given node.

=cut

sub new
{
    my ($class, $node, $column_names, $rows, @args) = @_;

    croak 'Missing node' unless $node;
    eval { ref($node) && $node->isa('DBIx::Tree::MaterializedPath::Node') }
      or
      do { croak 'Invalid node: not a "DBIx::Tree::MaterializedPath::Node"' };

    croak 'Missing column names' unless $column_names;
    croak 'Invalid column names' unless ref($column_names) eq 'ARRAY';

    croak 'Missing rows' unless $rows;
    croak 'Invalid rows' unless ref($rows) eq 'ARRAY';

    my $options = ref $args[0] eq 'HASH' ? $args[0] : {@args};

    my $ignore_empty_hash = $options->{ignore_empty_hash} ? 1 : 0;

    my $self = bless {}, ref($class) || $class;

    $self->{_node} = $node;

    # E.g. calling C on node "E" below:
    #
    #           A
    #        ___|_____
    #       |         |
    #       B         E
    #      _|_     ___|___
    #     |   |   |   |   |
    #     C   D   F   I   J
    #            _|_
    #           |   |
    #           G   H
    #
    # might produce column names that look like this:
    #
    # ['id', 'path', 'name']
    #
    # and database rows that look like this:
    #
    # [
    #   [  6, "1.2.1",   "F"],
    #   [  7, "1.2.1.1", "G"],
    #   [  8, "1.2.1.2", "H"],
    #   [  9, "1.2.2",   "I"],
    #   [ 10, "1.2.3",   "J"],
    # ]
    #
    # which results in the following data structure:
    #
    # [
    #   {
    #     node     => DBIx::Tree::MaterializedPath::Node "F",
    #     children => [
    #                   {
    #                     node     => DBIx::Tree::MaterializedPath::Node "G",
    #                     children => [],
    #                   },
    #                   {
    #                     node     => DBIx::Tree::MaterializedPath::Node "H",
    #                     children => [],
    #                   },
    #                 ],
    #   },
    #   {
    #     node     => DBIx::Tree::MaterializedPath::Node "I",
    #     children => [],
    #   },
    #   {
    #     node     => DBIx::Tree::MaterializedPath::Node "J",
    #     children => [],
    #   },
    # ]

    my $root = $node->get_root;

    my $num_nodes = 0;
    my @nodes     = ();

    if (@{$rows})
    {
        my $path_col = $root->{_path_column_name};

        my $ix_path_col = 0;
        my $found       = 0;
        foreach my $column_name (@{$column_names})
        {
            if ($column_name eq $path_col)
            {
                $found++;
                last;
            }
            $ix_path_col++;
        }
        croak 'Path column name not found' unless $found;

        my $path   = $rows->[0]->[$ix_path_col];
        my $length = length $path;

        _add_descendant_nodes(
                              {
                               prev_path   => q{},
                               prev_length => $length,
                               nodes       => \@nodes,
                              },
                              {
                               root              => $root,
                               ix_path_col       => $ix_path_col,
                               column_names      => $column_names,
                               num_nodes_ref     => \$num_nodes,
                               rows              => $rows,
                               ignore_empty_hash => $ignore_empty_hash
                              },
                             );
    }

    $self->{_descendants} = \@nodes;
    $self->{_num_nodes}   = $num_nodes;
    $self->{_has_nodes}   = $self->{_num_nodes} ? 1 : 0;

    return $self;
}

sub _add_descendant_nodes
{
    my ($args, $invariant_args) = @_;

    my $prev_path   = $args->{prev_path};
    my $prev_length = $args->{prev_length};
    my $nodes       = $args->{nodes};

    my $root              = $invariant_args->{root};
    my $ix_path_col       = $invariant_args->{ix_path_col};
    my $column_names      = $invariant_args->{column_names};
    my $num_nodes_ref     = $invariant_args->{num_nodes_ref};
    my $rows              = $invariant_args->{rows};
    my $ignore_empty_hash = $invariant_args->{ignore_empty_hash};

    my $node_children = undef;

    while (@{$rows})
    {
        my $path   = $rows->[0]->[$ix_path_col];
        my $length = length $path;

        # If path length is less, we've gone back up
        # a level in the tree:
        if ($length < $prev_length)
        {
            return;
        }

        # If path length is greater, we've gone down
        # a level in the tree:
        elsif ($length > $prev_length)
        {
            _add_descendant_nodes(
                                  {
                                   prev_path   => $prev_path,
                                   prev_length => $length,
                                   nodes       => $node_children,
                                  },
                                  $invariant_args,
                                 );
        }

        # If path length is the same, we're adding
        # siblings at the same level:
        else
        {
            my $row = shift @{$rows};

            if ($path eq $prev_path)
            {
                carp "Danger! Found multiple rows with path <$path>";
            }
            else
            {
                $prev_path = $path;
            }

            my %data = map { $_ => shift @{$row} } @{$column_names};
            my $child = DBIx::Tree::MaterializedPath::Node->new($root,
                     {data => \%data, ignore_empty_hash => $ignore_empty_hash});

            $node_children = [];
            push @{$nodes}, {node => $child, children => $node_children};
            ${$num_nodes_ref}++;
        }
    }

    return;
}

=head2 has_nodes

   $subtree_data->has_nodes()

Return true if the data structure contains any nodes.

=cut

sub has_nodes
{
    my ($self) = @_;
    return $self->{_has_nodes};
}

=head2 num_nodes

   $subtree_data->num_nodes()

Return the number of nodes in the data structure.

=cut

sub num_nodes
{
    my ($self) = @_;
    return $self->{_num_nodes};
}

=head2 traverse

    $subtree_data->traverse( $coderef, $optional_context )

Given a coderef, traverse down the data structure in leftmost
depth-first order and apply the coderef at each node.

The first argument to the I<$coderef> will be the node being
traversed.  The second argument to the I<$coderef> will be that
node's parent.

If supplied, I<$context> will be the third argument to the
coderef.  I<$context> can be a reference to a data structure that
can allow information to be carried along from node to node while
traversing the tree.

E.g. to count the number of descendants:

    my $context = {count => 0};
    my $coderef = sub {
        my ($node, $parent, $context) = @_;
        $context->{count}++;
    };

    my $descendants = $node->get_descendants();
    $descendants->traverse($coderef, $context);

    print "The node has $context->{count} descendants.\n";

Note that you may be able to use closure variables instead of
passing them along in I<$context>:

    my $count   = 0;
    my $coderef = sub {
        my ($node, $parent) = @_;
        $count++;
    };

    my $descendants = $node->get_descendants();
    $descendants->traverse($coderef, $context);

    print "The node has $count descendants.\n";

=cut

sub traverse
{
    my ($self, $coderef, $context) = @_;

    croak 'Missing coderef' unless $coderef;
    croak 'Invalid coderef' unless ref($coderef) eq 'CODE';

    return unless $self->{_has_nodes};
    $self->_traverse($self->{_node}, $self->{_descendants}, $coderef, $context);

    return;
}

sub _traverse
{
    my ($self, $parent, $descendants, $coderef, $context) = @_;

    foreach my $child (@{$descendants})
    {
        my $node = $child->{node};
        $coderef->($node, $parent, $context);

        my $children = $child->{children};
        if (@{$children})
        {
            $self->_traverse($node, $children, $coderef, $context);
        }
    }

    return;
}

###################################################################

1;

__END__