File Coverage

blib/lib/Data/Hive/Store/Hash/Nested.pm

Criterion	Covered	Total	%
statement	79	84	94.0
branch	27	30	90.0
condition	10	14	71.4
subroutine	24	26	92.3
pod	8	8	100.0
total	148	162	91.3

use strict;
use warnings;
package Data::Hive::Store::Hash::Nested 1.015;
# ABSTRACT: store a hive in nested hashrefs

use parent 'Data::Hive::Store';

#pod =head1 DESCRIPTION
#pod
#pod This is a simple store, primarily for testing, that will store hives in nested
#pod hashrefs.  All hives are represented as hashrefs, and their values are stored
#pod in the entry for the empty string.
#pod
#pod So, we could do this:
#pod
#pod   my $href = {};
#pod
#pod   my $hive = Data::Hive->NEW({
#pod     store_class => 'Hash',
#pod     store_args  => [ $href ],
#pod   });
#pod
#pod   $hive->foo->SET(1);
#pod   $hive->foo->bar->baz->SET(2);
#pod
#pod We would end up with C<$href> containing:
#pod
#pod   {
#pod     foo => {
#pod       ''  => 1,
#pod       bar => {
#pod         baz => {
#pod           '' => 2,
#pod         },
#pod       },
#pod     },
#pod   }
#pod
#pod Using empty keys results in a bigger, uglier dump, but allows a given hive to
#pod contain both a value and subhives.  B that this is different
#pod behavior compared with earlier releases, in which empty keys were not used and
#pod it was not legal to have a value and a hive at a given path.  It is possible,
#pod although fairly unlikely, that this format will change again.  The Hash store
#pod should generally be used for testing things that use a hive, as opposed for
#pod building hashes that will be used for anything else.
#pod
#pod =method new
#pod
#pod   my $store = Data::Hive::Store::Hash->new(\%hash);
#pod
#pod The only argument expected for C is a hashref, which is the hashref in
#pod which hive entries are stored.
#pod
#pod If no hashref is provided, a new, empty hashref will be used.
#pod
#pod =cut

sub new {
  my ($class, $href) = @_;
  $href = {} unless defined $href;

  return bless { store => $href } => $class;
}

#pod =method hash_store
#pod
#pod This method returns the hashref in which things are being used.  You should not
#pod alter its contents!
#pod
#pod =cut

sub hash_store {
  $_[0]->{store}
}

my $BREAK = "BREAK\n";

# Wow, this is quite a little machine!  Here's a slightly simplified overview
# of what it does:  -- rjbs, 2010-08-27
#
# As long as cond->(\@remaining_path) is true, execute step->($next,
# $current_hashref, \@remaining_path)
#
# If it dies with $BREAK, stop looping and return.  Once the cond returns
# false, return end->($current_hashref, \@remaining_path)
sub _descend {
  my ($self, $orig_path, $arg) = @_;
  my @path = @$orig_path;

  $arg ||= {};
  $arg->{step} or die "step is required";
  $arg->{cond} ||= sub { @{ shift() } };
  $arg->{end}  ||= sub { $_[0] };

  my $node = $self->hash_store;

  while ($arg->{cond}->(\@path)) {
    my $seg = shift @path;

    {
      local $SIG{__DIE__};
      eval { $arg->{step}->($seg, $node, \@path) };
    }

    return if $@ and $@ eq $BREAK;
    die $@ if $@;
    $node = $node->{$seg} ||= {};
  }

  return $arg->{end}->($node, \@path);
}

sub get {
  my ($self, $path) = @_;
  return $self->_descend(
    $path, {
      end  => sub { $_[0]->{''} },
      step => sub {
        my ($seg, $node) = @_;

        die $BREAK unless exists $node->{$seg};

        $node->{$seg} = { '' => $node->{$seg} } if ! ref $node->{$seg};
      }
    }
  );
}

sub set {
  my ($self, $path, $value) = @_;
  return $self->_descend(
    $path, {
      step => sub {
        my ($seg, $node, $path) = @_;
        if (exists $node->{$seg} and not ref $node->{$seg}) {
          _die("can't overwrite existing non-ref value: '$node->{$seg}'");
        }
      },
      cond => sub { @{ shift() } > 1 },
      end  => sub {
        my ($node, $path) = @_;
        $node->{$path->[0]}{''} = $value;
      },
    },
  );
}

#pod =method name
#pod
#pod The name returned by the Hash store is a string, potentially suitable for
#pod eval-ing, describing a hash dereference of a variable called C<< $STORE >>.
#pod
#pod   "$STORE->{foo}->{bar}"
#pod
#pod This is probably not very useful.  It might be replaced with something else in
#pod the future.
#pod
#pod =cut

sub name {
  my ($self, $path) = @_;
  return join '->', '$STORE', map { "{'$_'}" } @$path;
}

sub exists {
  my ($self, $path) = @_;
  return $self->_descend(
    $path, {
      step => sub {
        my ($seg, $node) = @_;
        die $BREAK unless exists $node->{$seg};

        $node->{$seg} = { '' => $node->{$seg} } if ! ref $node->{$seg};
      },
      end  => sub { return exists $_[0]->{''}; },
    },
  );
}

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

  my @to_check;

  return $self->_descend(
    $path, {
      step => sub {
        my ($seg, $node) = @_;
        die $BREAK unless exists $node->{$seg};
        $node->{$seg} = { '' => $node->{$seg} } if ! ref $node->{$seg};
        push @to_check, [ $node, $seg ];
      },
      cond => sub { @{ shift() } > 1 },
      end  => sub {
        my ($node, $final_path) = @_;

        $node->{ $final_path->[0] } = { '' => $node->{ $final_path->[0] } }
          unless ref $node->{ $final_path->[0] };

        my $this = $node->{ $final_path->[0] };
        my $rv = delete $this->{''};

        # Cleanup empty trees after deletion!  It would be convenient to have
        # ->_ascend, but I'm not likely to bother with writing it just yet.
        # -- rjbs, 2010-08-27
        for my $to_check (
          [ $node, $final_path->[0] ],
          reverse @to_check
        ) {
          my ($node, $seg) = @$to_check;
          last if keys %{ $node->{$seg} };
          delete $node->{ $seg };
        }

        return $rv;
      },
    },
  );
}

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

  return $self->_descend($path, {
    step => sub {
      my ($seg, $node) = @_;
      die $BREAK unless exists $node->{$seg};
      $node->{$seg} = { '' => $node->{$seg} } if ! ref $node->{$seg};
    },
    end  => sub {
      return grep { length } keys %{ $_[0] };
    },
  });
}

1;

__END__