lib/DBM/Deep/Hash.pm

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