File Coverage

blib/lib/JIP/DataPath.pm

Criterion	Covered	Total	%
statement	88	92	95.6
branch	34	40	85.0
condition	21	41	51.2
subroutine	17	17	100.0
pod	10	10	100.0
total	170	200	85.0

package JIP::DataPath;

use strict;
use warnings;

use Carp qw(croak);
use Exporter qw(import);
use English qw(-no_match_vars);

our $VERSION = '0.044';

our @EXPORT_OK = qw(path);

sub path {
    my ($document) = @ARG;

    return __PACKAGE__->new( document => $document );
}

sub default_value {
    return __PACKAGE__ . '::default_value';
}

sub is_default_value {
    my ( $self, $value ) = @ARG;

    return 0 if !defined $value;
    return 0 if ref $value;
    return 0 if $value ne $self->default_value();

    return 1;
}

sub document {
    my ($self) = @ARG;

    return $self->{document};
}

sub new {
    my ( $class, %param ) = @ARG;

    # Mandatory params
    if ( !exists $param{document} ) {
        croak 'Mandatory argument "document" is missing';
    }

    return bless(
        {
            document => $param{document},
        },
        $class,
    );
}

sub get {
    my ( $self, $path_parts, $default_value ) = @ARG;

    if ( @{$path_parts} == 0 ) {
        return $self->document();
    }

    my ( $contains, $context ) = $self->_accessor($path_parts);

    return $default_value if !$contains;

    my $last_part = $path_parts->[-1] // q{};
    my $type      = ref $context      // q{};

    if ( $type eq 'HASH' && length $last_part ) {
        return $context->{$last_part};
    }
    elsif ( $type eq 'ARRAY' && $last_part =~ m{^\d+$}x ) {
        return $context->[$last_part];
    }

    return $default_value;
} ## end sub get

sub get_new {
    my ( $self, $path_parts, $default_value ) = @ARG;

    if ( @{$path_parts} == 0 ) {
        return path( $self->document() );
    }

    my ( $contains, $context ) = $self->_accessor($path_parts);

    return $default_value if !$contains;

    my $last_part = $path_parts->[-1] // q{};
    my $type      = ref $context      // q{};

    if ( $type eq 'HASH' && length $last_part ) {
        return path( $context->{$last_part} );
    }
    elsif ( $type eq 'ARRAY' && $last_part =~ m{^\d+$}x ) {
        return path( $context->[$last_part] );
    }

    return $default_value;
} ## end sub get_new

sub contains {
    my ( $self, @xargs ) = @ARG;

    my ($contains) = $self->_accessor(@xargs);

    return $contains;
}

sub set {
    my ( $self, $path_parts, $value ) = @ARG;

    if ( @{$path_parts} == 0 ) {
        $self->_set_document($value);
        return 1;
    }

    my ( $contains, $context ) = $self->_accessor($path_parts);

    return 0 if !$contains;

    my $last_part = $path_parts->[-1] // q{};
    my $type      = ref $context      // q{};

    if ( $type eq 'HASH' && length $last_part ) {
        $context->{$last_part} = $value;
        return 1;
    }
    elsif ( $type eq 'ARRAY' && $last_part =~ m{^\d+$}x ) {
        $context->[$last_part] = $value;
        return 1;
    }

    return 0;
} ## end sub set

sub perform {
    my ( $self, $method, $path_parts, @xargs ) = @ARG;

    return $self->$method( $path_parts, @xargs );
}

sub _set_document {
    my ( $self, $document ) = @ARG;

    $self->{document} = $document;

    return;
}

sub _accessor {
    my ( $self, $path_parts ) = @ARG;

    my $context    = $self->document();
    my $last_index = $#{$path_parts};

    foreach my $part_index ( 0 .. $last_index ) {
        my $part = $path_parts->[$part_index];
        my $type = ref $context // q{};
        my $last = $part_index == $last_index;

        if ( $type eq 'HASH' && exists $context->{$part} ) {
            return ( 1, $context ) if $last;

            $context = $context->{$part};
        }
        elsif ( $type eq 'ARRAY' && $part =~ m{^\d+$}x && @{$context} > $part ) {
            return ( 1, $context ) if $last;

            $context = $context->[$part];
        }
        else {
            return ( 0, undef );
        }
    }

    return ( 1, $context );
} ## end sub _accessor

1;

__END__