File Coverage

blib/lib/Data/NestedKey.pm

Criterion	Covered	Total	%
statement	155	187	82.8
branch	61	94	64.8
condition	27	49	55.1
subroutine	19	20	95.0
pod	6	6	100.0
total	268	356	75.2

package Data::NestedKey;

# This module provides an object-oriented way to manipulate deeply
# nested hash structures using dot-separated keys, with flexible
# serialization options.

use strict;
use warnings;

use Carp;
use Data::Dumper;
use JSON;
use List::Util qw(pairs);
use Scalar::Util qw(reftype);
use Storable qw(nfreeze);
use YAML::XS ();

our $VERSION = '1.1.0';

# Package variables for serialization options
our $JSON_PRETTY = 1;  # Controls whether JSON output is pretty or compact
our $FORMAT = 'JSON';  # Default serialization format

use overload '""' => \&as_string;

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

  my $init_data = ref $args[0] ? shift @args : {};
  my @kv_list   = @args;

  # If the first argument is a hash reference, use it; otherwise, start with an empty structure
  my $self = bless { data => _is_hash($init_data) ? $init_data : {} }, $class;

  # If $init_data wasn't a hash ref, treat it as a key-value pair
  if ( !_is_hash($init_data) ) {
    @kv_list = ( $init_data, @kv_list );
  }

  # Short-circuit if no key-value pairs are provided
  return $self
    if !@kv_list;

  # Ensure key-value pairs are valid
  croak 'Must provide key-value pairs'
    if @kv_list && @kv_list % 2 != 0;

  # Populate the structure using `set`
  $self->set(@kv_list);

  return $self;
}

########################################################################
sub _is_array { return ref $_[0] && reftype( $_[0] ) eq 'ARRAY'; }
########################################################################

########################################################################
sub _is_hash { return ref $_[0] && reftype( $_[0] ) eq 'HASH'; }
########################################################################

# Parse a dot-separated path into a list of segment hashrefs.
# Each segment has:
#   key   => the hash key name
#   index => array index (integer, possibly negative), or undef if none
#
# Examples:
#   'foo.bar'             -> [{key=>'foo'},{key=>'bar'}]
#   'repositories[0].uri' -> [{key=>'repositories',index=>0},{key=>'uri'}]
#   'items[-1]'           -> [{key=>'items',index=>-1}]

########################################################################
sub _parse_path {
########################################################################
  my ($path) = @_;

  my @segments;

  for my $part ( split /[.]/, $path ) {
    if ( $part =~ /\A (.+?) \[ (-?\d+) \] \z/xsm ) {
      push @segments, { key => $1, index => $2 + 0 };
    }
    else {
      push @segments, { key => $part, index => undef };
    }
  }

  return @segments;
}

# Walk a parsed path down into $data, stopping one segment before the
# end.  Returns ($node, $final_segment) where $node is the innermost
# container the final segment lives in, or (undef, undef) if any
# intermediate step is missing or of the wrong type.
#
# If $create is true, missing intermediate hash keys are auto-vivified
# (mirrors the old behaviour in set()).  Array slots are never
# auto-vivified here — callers that need that must handle it themselves.

########################################################################
sub _walk {
########################################################################
  my ( $data, $segments, $create ) = @_;

  my $current = $data;

  for my $seg ( @{$segments}[ 0 .. $#{$segments} - 1 ] ) {
    my ( $key, $idx ) = @{$seg}{qw(key index)};

    # Step into the hash key
    if ( _is_hash($current) ) {
      $current->{$key} //= {} if $create && !exists $current->{$key};

      return ( undef, undef ) if !exists $current->{$key};

      $current = $current->{$key};
    }
    else {
      return ( undef, undef );
    }

    # If this segment also carries an array subscript, step into it
    if ( defined $idx ) {
      return ( undef, undef ) if !_is_array($current);

      $current = $current->[$idx];

      return ( undef, undef ) if !defined $current;
    }
  }

  return ( $current, $segments->[-1] );
}

########################################################################
sub set {
########################################################################
  my ( $self, @kv_list ) = @_;

  croak 'Must provide key-value pairs'
    if @kv_list % 2 != 0;

  for my $p ( pairs @kv_list ) {
    my ( $key_path, $value ) = @{$p};
    my $action = $key_path =~ s/\A([+-])//xsm ? $1 : q{};

    # set() does not support array subscripts in paths; use plain dot-keys only.
    croak "Array subscripts (e.g. key[0]) are not supported in set() paths: '$key_path'"
      if $key_path =~ /\[/;

    my @keys    = split /[.]/, $key_path;
    my $current = $self->{data};

    for my $key ( @keys[ 0 .. $#keys - 1 ] ) {
      $current->{$key} //= {};
      $current = $current->{$key};
    }

    my $final_key = $keys[-1];

    if ( $action eq q{+} ) {
      if ( _is_array( $current->{$final_key} ) ) {
        push @{ $current->{$final_key} }, $value;
      }
      elsif ( _is_hash( $current->{$final_key} ) && _is_hash($value) ) {
        %{ $current->{$final_key} } = ( %{ $current->{$final_key} }, %{$value} );
      }
      elsif ( _is_hash( $current->{$final_key} ) ) {
        croak sprintf q{Error: Attempting to merge a non-hash into a hash at key '%s'.}, $final_key;
      }
      elsif ( exists $current->{$final_key} ) {
        $current->{$final_key} = [ $current->{$final_key}, $value ];
      }
      else {
        $current->{$final_key} = [$value];
      }
    }
    elsif ( $action eq q{-} ) {
      if ( _is_array( $current->{$final_key} ) ) {
        @{ $current->{$final_key} } = grep { $_ ne $value } @{ $current->{$final_key} };
      }
      elsif ( _is_hash( $current->{$final_key} ) ) {
        delete $current->{$final_key}{$value};
      }
      else {
        delete $current->{$final_key};
      }
    }
    else {
      croak sprintf q{Error: Attempting to replace a hash reference at key '%s' with a scalar value.}, $final_key
        if _is_hash( $current->{$final_key} ) && !_is_hash($value);

      $current->{$final_key} = $value;
    }
  }

  return $self;
}

########################################################################
sub get {
########################################################################
  my ( $self, @key_paths ) = @_;
  my @results;

  for my $key_path (@key_paths) {
    my @segments = _parse_path($key_path);
    my $current  = $self->{data};
    my $ok       = 1;

    for my $seg (@segments) {
      my ( $key, $idx ) = @{$seg}{qw(key index)};

      if ( _is_hash($current) && exists $current->{$key} ) {
        $current = $current->{$key};
      }
      else {
        $current = undef;
        $ok      = 0;
        last;
      }

      if ( defined $idx ) {
        if ( _is_array($current) ) {
          $current = $current->[$idx];
        }
        else {
          $current = undef;
          $ok      = 0;
          last;
        }
      }
    }

    push @results, $ok ? $current : undef;
  }

  return wantarray ? @results : $results[0];
}

########################################################################
sub as_string {
########################################################################
  my ($self) = @_;

  return JSON->new->pretty->encode( $self->{data} ) if $FORMAT eq 'JSON' && $JSON_PRETTY;
  return JSON->new->encode( $self->{data} )         if $FORMAT eq 'JSON';
  return YAML::XS::Dump( $self->{data} )            if $FORMAT eq 'YAML';
  return Dumper( $self->{data} )                    if $FORMAT eq 'Dumper';
  return nfreeze( $self->{data} )                   if $FORMAT eq 'Storable';

  croak "Unsupported format: $FORMAT";
}

########################################################################
sub delete { ## no critic
########################################################################
  my ( $self, @key_paths ) = @_;

  for my $key_path (@key_paths) {
    my @segments = _parse_path($key_path);
    my @parents;  # Track parent containers for empty-hash cleanup
    my $current = $self->{data};
    my $abort   = 0;

    for my $seg ( @segments[ 0 .. $#segments - 1 ] ) {
      my ( $key, $idx ) = @{$seg}{qw(key index)};

      last if !_is_hash($current) || !exists $current->{$key};

      push @parents, [ $current, $key ];
      $current = $current->{$key};

      if ( defined $idx ) {
        if ( _is_array($current) ) {
          $current = $current->[$idx];

          if ( !defined $current ) {
            $abort = 1;
            last;
          }
          # Array slots are not tracked for empty-cleanup
          @parents = ();
        }
        else {
          $abort = 1;
          last;
        }
      }
    }

    next if $abort;

    my $final = $segments[-1];
    my ( $final_key, $final_idx ) = @{$final}{qw(key index)};

    if ( defined $final_idx ) {
      # Deleting a specific array slot: splice it out
      if ( _is_hash($current)
        && exists $current->{$final_key}
        && _is_array( $current->{$final_key} ) ) {
        splice @{ $current->{$final_key} }, $final_idx, 1;
      }
    }
    else {
      if ( _is_hash($current) && exists $current->{$final_key} ) {
        delete $current->{$final_key};
      }
    }

    # Cleanup empty parent hashes (only meaningful when no array was traversed)
    while (@parents) {
      my ( $parent, $key ) = @{ pop @parents };
      last if !_is_hash( $parent->{$key} ) || %{ $parent->{$key} };
      delete $parent->{$key};
    }
  }

  return $self;
}

########################################################################
sub exists_key {
########################################################################
  my ( $self, @key_paths ) = @_;
  my @results;

  for my $key_path (@key_paths) {
    my @segments = _parse_path($key_path);
    my $current  = $self->{data};
    my $exists   = 1;

    for my $seg (@segments) {
      my ( $key, $idx ) = @{$seg}{qw(key index)};

      if ( _is_hash($current) && exists $current->{$key} ) {
        $current = $current->{$key};
      }
      else {
        $exists = 0;
        last;
      }

      if ( defined $idx ) {
        if ( _is_array($current) && defined $current->[$idx] ) {
          $current = $current->[$idx];
        }
        else {
          $exists = 0;
          last;
        }
      }
    }

    push @results, $exists;
  }

  return wantarray ? @results : $results[0];
}

1;

__END__