File Coverage

blib/lib/Data/NestedKey.pm

Criterion	Covered	Total	%
statement	119	126	94.4
branch	41	56	73.2
condition	19	32	59.3
subroutine	18	18	100.0
pod	6	6	100.0
total	203	238	85.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.0.8';

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

########################################################################
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/^([+-])// ? $1 : q{};

    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 @keys    = split /[.]/, $key_path;
    my $current = $self->{data};

    for my $key (@keys) {
      if ( _is_hash($current) && exists $current->{$key} ) {
        $current = $current->{$key};
      }
      else {
        $current = undef;
        last;
      }
    }

    push @results, $current;
  }

  return wantarray ? @results : $results[0];  # Ensure it works in scalar and list context
}

########################################################################
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 @keys    = split /[.]/xsm, $key_path;
    my $current = $self->{data};
    my @parents;  # Track parent references

    for my $key ( @keys[ 0 .. $#keys - 1 ] ) {
      last if !_is_hash($current) || !exists $current->{$key};

      push @parents, [ $current, $key ];  # Store parent reference
      $current = $current->{$key};
    }

    my $final_key = $keys[-1];

    if ( exists $current->{$final_key} ) {
      delete $current->{$final_key};
    }

    # Cleanup empty parent hashes
    while (@parents) {
      my ( $parent, $key ) = @{ pop @parents };

      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 @keys    = split /[.]/xsm, $key_path;
    my $current = $self->{data};
    my $exists  = 1;

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

    push @results, $exists;
  }

  return wantarray ? @results : $results[0];  # Ensures proper scalar context behavior
}

1;

__END__