lib/DBM/Deep/Hash.pm

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