File Coverage

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

Criterion	Covered	Total	%
statement	153	153	100.0
branch	31	32	96.8
condition	13	17	76.4
subroutine	31	31	100.0
pod	19	19	100.0
total	247	252	98.0

package DBIx::Tree::MaterializedPath::PathMapper;

use warnings;
use strict;

use Carp;
use SQL::Abstract;

use Readonly;

Readonly::Scalar my $EMPTY_STRING => q{};

Readonly::Scalar my $DEFAULT_CHUNKSIZE => 5;
Readonly::Scalar my $MAX_CHUNKSIZE     => 8;

my $re_period = qr/[.]/msx;

=head1 NAME

DBIx::Tree::MaterializedPath::PathMapper - manipulates paths for "materialized path" trees

=head1 VERSION

Version 0.06

=cut

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

=head1 SYNOPSIS

    use DBIx::Tree::MaterializedPath::PathMapper;

    my $mapper = DBIx::Tree::MaterializedPath::PathMapper->new();

    # Path to the 2nd child of the 3rd child of the root node:
    my $path_in_db = $mapper->map('1.3.2');

    my $path = $mapper->unmap($path_in_db);    # "1.3.2"

=head1 DESCRIPTION

This module manipulates path representations for DBIx::Tree::MaterializedPath
"materialized path" trees.

=head2 PATH REPRESENTATIONS

The "human-readable" path is a sequence of integers separated by
periods that represents the path from the root node of the tree
to one of it's children.

The first integer (representing the root node) is always a "1".
Subsequent integers represent the Nth child node of the parent,
e.g. "1.7" would be the 7th child of the root node, and "1.7.2"
would be the 2nd child of the 7th child of the root node.

The "human-readable" path for each node is the tree is mapped
into a different format for storage in the database.  The format
used for database storage must meet several criteria in order for
tree manipulation via SQL to work:

=over 4

=item *

The human-readable path must map uniquely to the stored path,
and vice versa.

=item *

The stored path strings should sort such that the nodes they
represent would be traversed leftmost depth-first.

=item *

The length of each "chunk" of the stored path (where each chunk
represents one step deeper into the tree) should be a fixed value.
E.g. "1.108.15" could map to something like "001.108.015" if the
chunksize was 3. This ensures that the length of the path
representation is a function of the depth of the node in the tree.

=item *

The stored path may be prefixed with additional info, but there
should be no extraneous info at the end.  Removing one "chunk"
from the end of a node's path should always result in the path
for that node's parent.

=back

=head2 LIMITATIONS

This implementation uses a default chunksize of 5 when mapping
the digits in the human-readable path into a hex representation.
This means that the highest numbered child at any level is
0xfffff, or 1,048,575.

In addition to limiting the maximum children a node may have,
the chunksize also affects the length of the path strings and
thus the amount of database storage required.

The default chunksize may be overridden by passing a "chunksize"
option to C, with an integer value ranging from 1 to 8.

=head1 METHODS

=head2 new

    $mapper = DBIx::Tree::MaterializedPath::PathMapper->new()

Returns a path mapping object.

=cut

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

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

    my $self = bless {}, ref($class) || $class;
    $self->_init($options);
    return $self;
}

sub _init
{
    my ($self, $options) = @_;

    $self->{_version} = '1';    # must be single character

    # Size of storage format path chunks:
    $self->{_chunksize} = $options->{chunksize} || $DEFAULT_CHUNKSIZE;
    $self->{_chunksize} = $MAX_CHUNKSIZE
      if $self->{_chunksize} > $MAX_CHUNKSIZE;

    $self->{_sqlmaker} = SQL::Abstract->new();

    $self->{_cache} = {};

    return;
}

#
# Be sure to keep _parse_path() consistent with map()...
#
sub _parse_path
{
    my ($self, $path) = @_;
    my $extra     = substr($path, 0, 1);
    my $chunksize = substr($path, 1, 1);
    my $pathpart  = substr($path, 2);
    return ($chunksize, $pathpart, $extra);
}

=head2 is_root

    $mapper->is_root( $path )

Given a path, returns true if the path represents the root node.

=cut

# Be sure to keep is_root() consistent with map()...

sub is_root
{
    my ($self, $path) = @_;

    my ($chunksize, $pathpart) = $self->_parse_path($path);
    return $self->_is_root($chunksize, $pathpart) ? 1 : 0;
}

sub _is_root
{
    my ($self, $chunksize, $pathpart) = @_;
    return 0 unless $chunksize;
    return (length($pathpart) == $chunksize) ? 1 : 0;
}

=head2 depth

    $mapper->depth( $path )

Given a path, returns the depth of the node in the tree.
The root node is at zero depth.

=cut

sub depth
{
    my ($self, $path) = @_;

    my ($chunksize, $pathpart) = $self->_parse_path($path);
    return int(length($pathpart) / $chunksize) - 1;
}

=head2 map

    $mapper->map( $human_readable_path )

Maps a string representing the path from the root node of the tree
to a child node from human-readable format (e.g. "1.2.4.1") to the
format stored in the database.

=cut

sub map    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
{
    my ($self, $hrpath) = @_;

    my $chunksize = $self->{_chunksize};
    my $format    = '%0' . $chunksize . 'x';

    my $pathpart = join $EMPTY_STRING,
      map { sprintf($format, $_) } split($re_period, $hrpath);

    return $self->_map($chunksize, $pathpart);
}

sub _map
{
    my ($self, $chunksize, $pathpart) = @_;
    my $path = $self->{_version} . $chunksize . $pathpart;
    return $path;
}

#
# Be sure to keep _map_chunk() consisent with map()...
#
sub _map_chunk
{
    my ($self, $chunk, $chunksize) = @_;
    $chunksize ||= $self->{_chunksize};
    my $format = '%0' . $chunksize . 'x';
    return sprintf($format, $chunk);
}

=head2 unmap

    $mapper->unmap( $path )

Maps a string representing the path from the root node of the tree
to a child node from the format stored in the database to
human-readable format (e.g. "1.2.4.1").

=cut

sub unmap
{
    my ($self,      $path)     = @_;
    my ($chunksize, $pathpart) = $self->_parse_path($path);

    # This doesn't work in perl 5.6.1, the parentheses
    # for grouping and repeating are not allowed:
    #
    #my $format = "(A$chunksize)*";

    # Build an explicit format that works in Perl 5.6.1:
    my $num_chunks = int(length($pathpart) / $chunksize);
    my $format     = "A$chunksize" x $num_chunks;

    my $hrpath = join q{.}, map { hex $_ } unpack($format, $pathpart);
    return $hrpath;
}

#
# Be sure to keep _unmap_chunk() consistent with unmap()...
#
sub _unmap_chunk
{
    my ($self, $chunk) = @_;
    return hex($chunk);
}

=head2 parent_path

    $mapper->parent_path( $path )

Given a path to a node, return the path to its immediate parent.

Returns an empty string if the input path represents the root node.

=cut

sub parent_path
{
    my ($self, $path) = @_;

    my ($chunksize, $pathpart) = $self->_parse_path($path);

    return $EMPTY_STRING if $self->_is_root($chunksize, $pathpart);

    my $parentpathpart = substr($pathpart, 0, -$chunksize);

    return $self->_map($chunksize, $parentpathpart);
}

=head2 first_child_path

    $mapper->first_child_path( $path )

Given a path to a node, return a path to the first child
of that node.

=cut

sub first_child_path
{
    my ($self, $path) = @_;

    my ($chunksize, $pathpart) = $self->_parse_path($path);

    return $path . $self->_map_chunk(1, $chunksize);
}

=head2 next_child_path

    $mapper->next_child_path( $path, $optional_n )

Given a path to a child node, return a path to the next child
for the same parent.

If I<$n> is specified, return the path to the nth next child.
(I<$n> effectively defaults to 1.)

Returns an empty string if the input path represents the root node.

=cut

sub next_child_path
{
    my ($self, $path, $n) = @_;
    $n ||= 1;

    my ($chunksize, $pathpart) = $self->_parse_path($path);

    return $EMPTY_STRING if $self->_is_root($chunksize, $pathpart);

    my $last_chunk = substr($path, -$chunksize);
    $last_chunk = $self->_unmap_chunk($last_chunk);
    $last_chunk += $n;
    $last_chunk = $self->_map_chunk($last_chunk, $chunksize);
    substr($path, -$chunksize) = $last_chunk;

    return $path;
}

=head2 where

    $mapper->where( $where )

Given an L-styleSQL "where"
data structure, return an SQL "where" clause,
and the corresponding array of bind params.

=cut

sub where
{
    my ($self, $where) = @_;

    my $sqlmaker = $self->{_sqlmaker};
    my ($sql, @bind_params) = $sqlmaker->where($where);
    return ($sql, @bind_params);
}

=head2 child_where

    $mapper->child_where( $path_column_name, $path )

Given the name of the path column and a path to a node,
return an SQL "where" clause suitable for finding the node's
direct children, and the corresponding array of bind params.

=cut

sub child_where
{
    my ($self, $path_col, $path) = @_;

    my ($chunksize, $pathpart) = $self->_parse_path($path);

    my $like = $path . ('_' x $chunksize);

    my $sqlmaker = $self->{_sqlmaker};
    my ($sql, @bind_params) = $sqlmaker->where({$path_col => {-like => $like}});
    return ($sql, @bind_params);
}

=head2 sibling_where

    $mapper->sibling_where( $path_column_name, $path )

Given the name of the path column and a path to a node,
return an SQL "where" clause suitable for finding the node's
siblings, and the corresponding array of bind params.

=cut

sub sibling_where
{
    my ($self, $path_col, $path) = @_;

    my ($chunksize, $pathpart) = $self->_parse_path($path);

    my $like = $path;
    substr($like, -$chunksize) = '_' x $chunksize;

    my $sqlmaker = $self->{_sqlmaker};
    my ($sql, @bind_params) = $sqlmaker->where({$path_col => {-like => $like}});
    return ($sql, @bind_params);
}

=head2 sibling_to_the_right_where

    $mapper->sibling_to_the_right_where( $path_column_name, $path )

Given the name of the path column and a path to a node,
return an SQL "where" clause suitable for finding siblings
to the right of the node, and the corresponding array of bind
params.

=cut

sub sibling_to_the_right_where
{
    my ($self, $path_col, $path) = @_;

    my ($chunksize, $pathpart) = $self->_parse_path($path);

    my $like = $path;
    substr($like, -$chunksize) = '_' x $chunksize;

    my $sqlmaker = $self->{_sqlmaker};
    my ($sql, @bind_params) = $sqlmaker->where(
                     {$path_col => [-and => {-like => $like}, {'>' => $path}]});
    return ($sql, @bind_params);
}

=head2 sibling_to_the_left_where

    $mapper->sibling_to_the_left_where( $path_column_name, $path )

Given the name of the path column and a path to a node,
return an SQL "where" clause suitable for finding siblings
to the left of the node, and the corresponding array of bind
params.

=cut

sub sibling_to_the_left_where
{
    my ($self, $path_col, $path) = @_;

    my ($chunksize, $pathpart) = $self->_parse_path($path);

    my $like = $path;
    substr($like, -$chunksize) = '_' x $chunksize;

    my $sqlmaker = $self->{_sqlmaker};
    my ($sql, @bind_params) = $sqlmaker->where(
                     {$path_col => [-and => {-like => $like}, {'<' => $path}]});
    return ($sql, @bind_params);
}

=head2 descendants_where_struct

    $mapper->descendants_where_struct( $path_column_name, $path )

Given the name of the path column and a path to a node,
return an L-styleSQL "where"
data structure suitable for finding all of
the node's descendants.

=cut

sub descendants_where_struct
{
    my ($self, $path_col, $path) = @_;

    my $cache = $self->{_cache};
    my $key   = 'descendants_where_struct';

    unless ($cache->{$key}->{$path_col}->{$path})
    {
        my $like = $path . q{%};

        $cache->{$key}->{$path_col}->{$path} =
          {$path_col => [-and => {-like => $like}, {q{!=} => $path}]};
    }

    return $cache->{$key}->{$path_col}->{$path};
}

=head2 descendants_where

    $mapper->descendants_where( $path_column_name, $path )

Given the name of the path column and a path to a node,
return an SQL "where" clause suitable for finding all of
the node's descendants, and the corresponding array of
bind params.

=cut

sub descendants_where
{
    my ($self, $path_col, $path) = @_;

    my $cache = $self->{_cache};
    my $key   = 'descendants_where';

    unless ($cache->{$key}->{$path_col}->{$path})
    {
        my $where = $self->descendants_where_struct($path_col, $path);

        my $sqlmaker = $self->{_sqlmaker};
        my ($sql, @bind_params) = $sqlmaker->where($where);
        $cache->{$key}->{$path_col}->{$path} = {
                                                sql         => $sql,
                                                bind_params => \@bind_params,
                                               };
    }

    my $data = $cache->{$key}->{$path_col}->{$path};
    return ($data->{sql}, @{$data->{bind_params}});
}

=head2 descendants_and_self_where

    $mapper->descendants_and_self_where( $path_column_name, $path )

Given the name of the path column and a path to a node,
return an SQL "where" clause suitable for finding a node and
all of its descendants, and the corresponding array of
bind params.

=cut

sub descendants_and_self_where
{
    my ($self, $path_col, $path) = @_;

    my $like = $path . q{%};

    my $sqlmaker = $self->{_sqlmaker};
    my ($sql, @bind_params) = $sqlmaker->where({$path_col => {-like => $like}});
    return ($sql, @bind_params);
}

=head2 parent_where

    $mapper->parent_where( $path_column_name, $path )

Given the name of the path column and a path to a node,
return an SQL "where" clause suitable for finding the node's
parent, and the corresponding array of bind params.

=cut

sub parent_where
{
    my ($self, $path_col, $path) = @_;

    my ($sql, @bind_params) = (undef, undef);

    my $parent_path = $self->parent_path($path);
    if ($parent_path)
    {
        my $sqlmaker = $self->{_sqlmaker};
        ($sql, @bind_params) = $sqlmaker->where({$path_col => $parent_path});
    }
    return ($sql, @bind_params);
}

=head2 is_ancestor_of

    $mapper->is_ancestor_of( $path1, $path2 )

Return true if I represents an ancestor of I.

Returns false if I and I represent the same node.

=cut

sub is_ancestor_of
{
    my ($self, $path1, $path2) = @_;

    croak 'Missing path' unless $path1 && $path2;

    return 0 if $path1 eq $path2;
    return (substr($path2, 0, length($path1)) eq $path1) ? 1 : 0;
}

=head2 is_descendant_of

    $mapper->is_descendant_of( $path1, $path2 )

Return true if I represents a descendant of I.

Returns false if I and I represent the same node.

=cut

sub is_descendant_of
{
    my ($self, $path1, $path2) = @_;

    croak 'Missing path' unless $path1 && $path2;

    return 0 if $path1 eq $path2;
    return (substr($path1, 0, length($path2)) eq $path2) ? 1 : 0;
}

1;

__END__