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

    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"

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

    $mapper->is_root( $path )

    $mapper->depth( $path )

    $mapper->map( $human_readable_path )

    $mapper->unmap( $path )

    $mapper->parent_path( $path )

    $mapper->first_child_path( $path )

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

    $mapper->where( $where )

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

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

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

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

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

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

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

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

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

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

    perldoc DBIx::Tree::MaterializedPath::PathMapper

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;

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

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);
}

# 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;
}

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

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

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);
}

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);
}

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);
}

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

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

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

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;
}

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

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

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);
}

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);
}

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);
}

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);
}

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};
}

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}});
}

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);
}

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);
}

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;
}

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__