view release on metacpan or  search on metacpan

lib/Data/Hive/Store/Hash/Nested.pm  view on Meta::CPAN

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<Please note> 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<new> 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};