File Coverage

blib/lib/Data/PathSimple.pm

Criterion	Covered	Total	%
statement	69	69	100.0
branch	44	46	95.6
condition	8	8	100.0
subroutine	8	8	100.0
pod	2	2	100.0
total	131	133	98.5

package Data::PathSimple;

use strict;
use warnings;

use version 0.77;
our $VERSION = qv("v2.0.1");

use Scalar::Util qw[ reftype ];

use base 'Exporter';
our @EXPORT_OK = qw{
  get
  set
};

sub _error {
    'CODE' eq ref $_[0] ? $_[0]->() : $_[0];
}

sub get {

  my ( $root_ref, $root_path, $options ) = @_;

  my %opts = ( path_sep => '/',
	       error => undef,
	       %{ $options // {} },
	     );

  return _error( $opts{error} ) unless defined $root_path;

  my $path_sep = $opts{path_sep};
  $path_sep = qr/\Q$path_sep\E/
    unless ( reftype( $path_sep ) // '' ) eq 'REGEXP';

  $root_path =~ s/^$path_sep//;

  my @root_parts  = split $path_sep, $root_path;
  my $current_ref = $root_ref;

  return _error( $opts{error} ) unless @root_parts;

  foreach my $current_part ( @root_parts ) {
    if ( ref $current_ref eq 'HASH' ) {
      if ( exists $current_ref->{$current_part} ) {
        $current_ref = $current_ref->{$current_part};
        next;
      }
    }
    elsif ( ref $current_ref eq 'ARRAY' ) {
      return _error( $opts{error} ) if $current_part !~ /^\d+$/;

      if ( exists $current_ref->[$current_part] ) {
        $current_ref = $current_ref->[$current_part];
        next;
      }
    }

    return _error( $opts{error} );
  }

  return $current_ref;
}

sub set {

  my ( $root_ref, $root_path, $value, $options ) = @_;

  my %opts = ( path_sep => '/',
	       error => undef,
	       %{ $options // {} },
	     );

  return _error( $opts{error} ) unless defined $root_path;

  my $path_sep = $opts{path_sep};
  $path_sep = qr/\Q$path_sep\E/
    unless ( reftype( $path_sep ) // '' ) eq 'REGEXP';

  $root_path  =~ s/^$path_sep//;

  my @root_parts  = split $path_sep, $root_path;
  my $current_ref = $root_ref;

  return _error( $opts{error} ) unless @root_parts;

  for ( my $i = 0; $i < ( @root_parts - 1 ); $i++ ) {
    my $current_part = $root_parts[ $i ];
    my $next_part    = $root_parts[ $i + 1 ];

    if ( ref $current_ref eq 'HASH' ) {
      if ( not ref $current_ref->{$current_part} ) {

        # don't use an integer as a hash key if need to
        # create the next level in the tree
        return undef if $current_part =~ /^\d+$/;

        $current_ref->{$current_part}
          = $next_part =~ /^\d+$/
            ? []
            : {};
      }

      $current_ref = $current_ref->{$current_part};
      next;
    }
    elsif ( ref $current_ref eq 'ARRAY' ) {
      return _error( $opts{error} ) if $current_part !~ /^\d+$/;

      if ( not ref $current_ref->[$current_part] ) {
        $current_ref->[$current_part]
          = $next_part =~ /^\d+$/
            ? []
            : {};
      }

      $current_ref = $current_ref->[$current_part];
      next;
    }

    # ! ref $root_ref && @root_parts > 1
    return _error( $opts{error} );
  }

  my $last_part = pop @root_parts;

  if ( ref $current_ref eq 'HASH' ) {
    return $current_ref->{$last_part} = $value;
  }

  if ( ref $current_ref eq 'ARRAY' ) {
    return _error( $opts{error} ) if $last_part !~ /^\d+$/;
    return $current_ref->[$last_part] = $value;
  }

  # ! ref $root_ref && @root_parts == 1
  return _error( $opts{error} );
}

1;

__END__