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->_storage->{filter_store_key})
  32         ? $self->_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->_storage->{filter_store_key})
  42         ? $self->_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->_storage->{filter_store_key})
  53         ? $self->_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->_storage->{filter_store_key})
  63         ? $self->_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     ##
  76     # Request shared lock for reading
  77     ##
  78     $self->lock( $self->LOCK_SH );
  79
  80     my $result = $self->_engine->get_next_key( $self );
  81
  82     $self->unlock();
  83
  84     return ($result && $self->_storage->{filter_fetch_key})
  85         ? $self->_storage->{filter_fetch_key}->($result)
  86         : $result;
  87 }
  88
  89 sub NEXTKEY {
  90     ##
  91     # Return next key (in no particular order), given previous one
  92     ##
  93     my $self = shift->_get_self;
  94
  95     my $prev_key = ($self->_storage->{filter_store_key})
  96         ? $self->_storage->{filter_store_key}->($_[0])
  97         : $_[0];
  98
  99     ##
 100     # Request shared lock for reading
 101     ##
 102     $self->lock( $self->LOCK_SH );
 103
 104     my $result = $self->_engine->get_next_key( $self, $prev_key );
 105
 106     $self->unlock();
 107
 108     return ($result && $self->_storage->{filter_fetch_key})
 109         ? $self->_storage->{filter_fetch_key}->($result)
 110         : $result;
 111 }
 112
 113 ##
 114 # Public method aliases
 115 ##
 116 sub first_key { (shift)->FIRSTKEY(@_) }
 117 sub next_key { (shift)->NEXTKEY(@_) }
 118
 119 sub _copy_node {
 120     my $self = shift;
 121     my ($db_temp) = @_;
 122
 123     my $key = $self->first_key();
 124     while ($key) {
 125         my $value = $self->get($key);
 126         $self->_copy_value( \$db_temp->{$key}, $value );
 127         $key = $self->next_key($key);
 128     }
 129
 130     return 1;
 131 }
 132
 133 1;
 134 __END__