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 { tied( %{$_[0]} ) } || $_[0]
   9 }
  10
  11 sub TIEHASH {
  12     ##
  13     # Tied hash constructor method, called by Perl's tie() function.
  14     ##
  15     my $class = shift;
  16     my $args;
  17     if (scalar(@_) > 1) {
  18         if ( @_ % 2 ) {
  19             $class->_throw_error( "Odd number of parameters to TIEHASH" );
  20         }
  21         $args = {@_};
  22     }
  23         elsif ( my $type = Scalar::Util::reftype($_[0]) ) {
  24         if ( $type ne 'HASH' ) {
  25             $class->_throw_error( "Not a hashref in TIEHASH" );
  26         }
  27         $args = $_[0];
  28     }
  29     else { $args = { file => shift }; }
  30
  31     $args->{type} = $class->TYPE_HASH;
  32
  33     return $class->_init($args);
  34 }
  35
  36 sub FETCH {
  37     my $self = shift->_get_self;
  38     my $key = ($self->root->{filter_store_key})
  39         ? $self->root->{filter_store_key}->($_[0])
  40         : $_[0];
  41
  42     return $self->SUPER::FETCH( $key );
  43 }
  44
  45 sub STORE {
  46     my $self = shift->_get_self;
  47         my $key = ($self->root->{filter_store_key})
  48         ? $self->root->{filter_store_key}->($_[0])
  49         : $_[0];
  50     my $value = $_[1];
  51
  52     return $self->SUPER::STORE( $key, $value );
  53 }
  54
  55 sub EXISTS {
  56     my $self = shift->_get_self;
  57         my $key = ($self->root->{filter_store_key})
  58         ? $self->root->{filter_store_key}->($_[0])
  59         : $_[0];
  60
  61     return $self->SUPER::EXISTS( $key );
  62 }
  63
  64 sub FIRSTKEY {
  65         ##
  66         # Locate and return first key (in no particular order)
  67         ##
  68     my $self = $_[0]->_get_self;
  69
  70         ##
  71         # Make sure file is open
  72         ##
  73         if (!defined($self->fh)) { $self->_open(); }
  74
  75         ##
  76         # Request shared lock for reading
  77         ##
  78         $self->lock( $self->LOCK_SH );
  79
  80         my $result = $self->_get_next_key();
  81
  82         $self->unlock();
  83
  84         return ($result && $self->root->{filter_fetch_key})
  85         ? $self->root->{filter_fetch_key}->($result)
  86         : $result;
  87 }
  88
  89 sub NEXTKEY {
  90         ##
  91         # Return next key (in no particular order), given previous one
  92         ##
  93     my $self = $_[0]->_get_self;
  94
  95         my $prev_key = ($self->root->{filter_store_key})
  96         ? $self->root->{filter_store_key}->($_[1])
  97         : $_[1];
  98
  99         my $prev_md5 = $DBM::Deep::DIGEST_FUNC->($prev_key);
 100
 101         ##
 102         # Make sure file is open
 103         ##
 104         if (!defined($self->fh)) { $self->_open(); }
 105
 106         ##
 107         # Request shared lock for reading
 108         ##
 109         $self->lock( $self->LOCK_SH );
 110
 111         my $result = $self->_get_next_key( $prev_md5 );
 112
 113         $self->unlock();
 114
 115         return ($result && $self->root->{filter_fetch_key})
 116         ? $self->root->{filter_fetch_key}->($result)
 117         : $result;
 118 }
 119
 120 ##
 121 # Public method aliases
 122 ##
 123 *first_key = *FIRSTKEY;
 124 *next_key = *NEXTKEY;
 125
 126 1;
 127 __END__