lib/DBM/Deep/Hash.pm

   1 package DBM::Deep::Hash;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 use base 'DBM::Deep';
   9
  10 sub _get_self {
  11     eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0]
  12 }
  13
  14 sub _repr { return {} }
  15
  16 sub TIEHASH {
  17     ##
  18     # Tied hash constructor method, called by Perl's tie() function.
  19     ##
  20     my $class = shift;
  21     my $args = $class->_get_args( @_ );
  22
  23     $args->{type} = $class->TYPE_HASH;
  24
  25     return $class->_init($args);
  26 }
  27
  28 sub FETCH {
  29     my $self = shift->_get_self;
  30     DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0];
  31     my $key = ($self->_engine->storage->{filter_store_key})
  32         ? $self->_engine->storage->{filter_store_key}->($_[0])
  33         : $_[0];
  34
  35     return $self->SUPER::FETCH( $key, $_[0] );
  36 }
  37
  38 sub STORE {
  39     my $self = shift->_get_self;
  40     DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0];
  41     my $key = ($self->_engine->storage->{filter_store_key})
  42         ? $self->_engine->storage->{filter_store_key}->($_[0])
  43         : $_[0];
  44     my $value = $_[1];
  45
  46     return $self->SUPER::STORE( $key, $value, $_[0] );
  47 }
  48
  49 sub EXISTS {
  50     my $self = shift->_get_self;
  51     DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0];
  52     my $key = ($self->_engine->storage->{filter_store_key})
  53         ? $self->_engine->storage->{filter_store_key}->($_[0])
  54         : $_[0];
  55
  56     return $self->SUPER::EXISTS( $key );
  57 }
  58
  59 sub DELETE {
  60     my $self = shift->_get_self;
  61     DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0];
  62     my $key = ($self->_engine->storage->{filter_store_key})
  63         ? $self->_engine->storage->{filter_store_key}->($_[0])
  64         : $_[0];
  65
  66     return $self->SUPER::DELETE( $key, $_[0] );
  67 }
  68
  69 sub FIRSTKEY {
  70     ##
  71     # Locate and return first key (in no particular order)
  72     ##
  73     my $self = shift->_get_self;
  74
  75     $self->lock_shared;
  76
  77     my $result = $self->_engine->get_next_key( $self );
  78
  79     $self->unlock;
  80
  81     return ($result && $self->_engine->storage->{filter_fetch_key})
  82         ? $self->_engine->storage->{filter_fetch_key}->($result)
  83         : $result;
  84 }
  85
  86 sub NEXTKEY {
  87     ##
  88     # Return next key (in no particular order), given previous one
  89     ##
  90     my $self = shift->_get_self;
  91
  92     my $prev_key = ($self->_engine->storage->{filter_store_key})
  93         ? $self->_engine->storage->{filter_store_key}->($_[0])
  94         : $_[0];
  95
  96     $self->lock_shared;
  97
  98     my $result = $self->_engine->get_next_key( $self, $prev_key );
  99
 100     $self->unlock;
 101
 102     return ($result && $self->_engine->storage->{filter_fetch_key})
 103         ? $self->_engine->storage->{filter_fetch_key}->($result)
 104         : $result;
 105 }
 106
 107 ##
 108 # Public method aliases
 109 ##
 110 sub first_key { (shift)->FIRSTKEY(@_) }
 111 sub next_key { (shift)->NEXTKEY(@_) }
 112
 113 sub _copy_node {
 114     my $self = shift;
 115     my ($db_temp) = @_;
 116
 117     my $key = $self->first_key();
 118     while ($key) {
 119         my $value = $self->get($key);
 120         $self->_copy_value( \$db_temp->{$key}, $value );
 121         $key = $self->next_key($key);
 122     }
 123
 124     return 1;
 125 }
 126
 127 1;
 128 __END__