File Coverage

blib/lib/Mixin/ExtraFields/Driver/HashGuts.pm

Criterion	Covered	Total	%
statement	45	45	100.0
branch	6	6	100.0
condition	7	11	63.6
subroutine	16	16	100.0
pod	13	13	100.0
total	87	91	95.6

use strict;
use warnings;

package Mixin::ExtraFields::Driver::HashGuts 0.140003;
use parent qw(Mixin::ExtraFields::Driver);
# ABSTRACT: store extras in a hashy object's guts

#pod =head1 SYNOPSIS
#pod
#pod   package Your::HashBased::Class;
#pod
#pod   use Mixin::ExtraFields -fields => { driver => 'HashGuts' };
#pod
#pod =head1 DESCRIPTION
#pod
#pod This driver class implements an extremely simple storage mechanism: extras are
#pod stored on the object on which the mixed-in methods are called.  By default,
#pod they are stored under the key returned by the C> method,
#pod but this can be changed by providing a C argument to the driver
#pod configuration, like so:
#pod
#pod   use Mixin::ExtraFields -fields => {
#pod     driver => { class => 'HashGuts', hash_key => "\0Something\0Wicked\0" }
#pod   };
#pod
#pod =head1 METHODS
#pod
#pod In addition to the methods required by Mixin::ExtraFields::Driver, the
#pod following methods are provided:
#pod
#pod =head2 hash_key
#pod
#pod   my $key = $driver->hash_key;
#pod
#pod This method returns the key where the driver will store its extras.
#pod
#pod =cut

sub hash_key {
  my ($self) = @_;
  return $self->{hash_key};
}

#pod =head2 default_hash_key
#pod
#pod If no C argument is given for the driver, this method is called
#pod during driver initialization.  It will return a unique string to be used as the
#pod hash key.
#pod
#pod =cut

my $i = 0;
sub default_hash_key {
  my ($self) = @_;
  return "$self" . '@' . $i++;
}

#pod =head2 storage
#pod
#pod This method returns the hashref of storage used for extras.  Individual objects
#pod get weak references to their id within this hashref.
#pod
#pod =cut

sub storage { $_[0]->{storage} }

#pod =head2 storage_for
#pod
#pod   my $stash = $driver->storage_for($object, $id);
#pod
#pod This method returns the hashref to use to store extras for the given object and
#pod id.  This hashref is stored on both the hash-based object (in its C
#pod entry) and on the driver (in the entry for C<$id> in its C hash).
#pod
#pod All objects with the same id should end up with the same hash in their
#pod C field.  B of these references are weakened, which means two
#pod things:  first, even if all objects with a given id go out of scope, future
#pod objects with that id will retain the original extras; secondly, memory used to
#pod store extras is never reclaimed.  If this is a problem, use a more
#pod sophisticated driver.
#pod
#pod =cut

sub storage_for {
  my ($self, $object, $id) = @_;

  my $store = $self->storage->{ $id } ||= {};

  unless ($object->{ $self->hash_key }||0 == $store) {
    $object->{ $self->hash_key } ||= $store;
  }

  return $store
}

sub from_args {
  my ($class, $arg) = @_;

  my $self = bless { storage => {} } => $class;

  $self->{hash_key} = $arg->{hash_key} || $self->default_hash_key;

  return $self;
}

sub exists_extra {
  my ($self, $object, $id, $name) = @_;

  return exists $self->storage_for($object, $id)->{$name};
}

sub get_extra {
  my ($self, $object, $id, $name) = @_;

  # avoid autovivifying entries on get.
  return unless $self->exists_extra($object, $id, $name);
  return $self->storage_for($object, $id)->{$name};
}

sub get_detailed_extra {
  my ($self, $object, $id, $name) = @_;

  # avoid autovivifying entries on get.
  return unless $self->exists_extra($object, $id, $name);
  return { value => $self->storage_for($object, $id)->{$name} };
}

sub get_all_detailed_extra {
  my ($self, $object, $id) = @_;

  my $stash = $self->storage_for($object, $id);
  my @all_detailed = map { $_ => { value => $stash->{$_} } } keys %$stash;
}

sub get_all_extra {
  my ($self, $object, $id) = @_;

  return %{ $self->storage_for($object, $id) };
}

sub set_extra {
  my ($self, $object, $id, $name, $value) = @_;

  $self->storage_for($object, $id)->{$name} = $value;
}

sub delete_extra {
  my ($self, $object, $id, $name) = @_;

  delete $self->storage_for($object, $id)->{$name};
}

sub delete_all_extra {
  my ($self, $object, $id) = @_;
  %{ $self->storage_for($object, $id) } = ();
}

1;

__END__