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     my $class = shift;
  18     my $args = $class->_get_args( @_ );
  19
  20     $args->{type} = $class->TYPE_HASH;
  21
  22     return $class->_init($args);
  23 }
  24
  25 sub FETCH {
  26     my $self = shift->_get_self;
  27     DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0];
  28     my $key = ($self->_engine->storage->{filter_store_key})
  29         ? $self->_engine->storage->{filter_store_key}->($_[0])
  30         : $_[0];
  31
  32     return $self->SUPER::FETCH( $key, $_[0] );
  33 }
  34
  35 sub STORE {
  36     my $self = shift->_get_self;
  37     DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0];
  38     my $key = ($self->_engine->storage->{filter_store_key})
  39         ? $self->_engine->storage->{filter_store_key}->($_[0])
  40         : $_[0];
  41     my $value = $_[1];
  42
  43     return $self->SUPER::STORE( $key, $value, $_[0] );
  44 }
  45
  46 sub EXISTS {
  47     my $self = shift->_get_self;
  48     DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0];
  49     my $key = ($self->_engine->storage->{filter_store_key})
  50         ? $self->_engine->storage->{filter_store_key}->($_[0])
  51         : $_[0];
  52
  53     return $self->SUPER::EXISTS( $key );
  54 }
  55
  56 sub DELETE {
  57     my $self = shift->_get_self;
  58     DBM::Deep->_throw_error( "Cannot use an undefined hash key." ) unless defined $_[0];
  59     my $key = ($self->_engine->storage->{filter_store_key})
  60         ? $self->_engine->storage->{filter_store_key}->($_[0])
  61         : $_[0];
  62
  63     return $self->SUPER::DELETE( $key, $_[0] );
  64 }
  65
  66 # Locate and return first key (in no particular order)
  67 sub FIRSTKEY {
  68     my $self = shift->_get_self;
  69
  70     $self->lock_shared;
  71
  72     my $result = $self->_engine->get_next_key( $self );
  73
  74     $self->unlock;
  75
  76     return ($result && $self->_engine->storage->{filter_fetch_key})
  77         ? $self->_engine->storage->{filter_fetch_key}->($result)
  78         : $result;
  79 }
  80
  81 # Return next key (in no particular order), given previous one
  82 sub NEXTKEY {
  83     my $self = shift->_get_self;
  84
  85     my $prev_key = ($self->_engine->storage->{filter_store_key})
  86         ? $self->_engine->storage->{filter_store_key}->($_[0])
  87         : $_[0];
  88
  89     $self->lock_shared;
  90
  91     my $result = $self->_engine->get_next_key( $self, $prev_key );
  92
  93     $self->unlock;
  94
  95     return ($result && $self->_engine->storage->{filter_fetch_key})
  96         ? $self->_engine->storage->{filter_fetch_key}->($result)
  97         : $result;
  98 }
  99
 100 sub first_key { (shift)->FIRSTKEY(@_) }
 101 sub next_key  { (shift)->NEXTKEY(@_)  }
 102
 103 sub _copy_node {
 104     my $self = shift;
 105     my ($db_temp) = @_;
 106
 107     my $key = $self->first_key();
 108     while ($key) {
 109         my $value = $self->get($key);
 110         $self->_copy_value( \$db_temp->{$key}, $value );
 111         $key = $self->next_key($key);
 112     }
 113
 114     return 1;
 115 }
 116
 117 1;
 118 __END__