view release on metacpan or  search on metacpan

lib/Mixin/ExtraFields/Driver/HashGuts.pm  view on Meta::CPAN

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

#pod =head2 default_hash_key
#pod
#pod If no C<hash_key> 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<hash_key>
#pod entry) and on the driver (in the entry for C<$id> in its C<storage> hash).
#pod
#pod All objects with the same id should end up with the same hash in their
#pod C<hash_key> field.  B<None> 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;