lib/DBM/Deep/Hash.pm

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