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