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