client-libraries/perl/lib/Redis/Hash.pm

   1 package Redis::Hash;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Tie::Hash;
   7 use base qw/Redis Tie::StdHash/;
   8
   9 use Data::Dump qw/dump/;
  10
  11 =head1 NAME
  12
  13 Redis::Hash - tie perl hashes into Redis
  14
  15 =head1 SYNOPSYS
  16
  17   tie %name, 'Redis::Hash', 'prefix';
  18
  19 =cut
  20
  21 # mandatory methods
  22 sub TIEHASH {
  23         my ($class,$name) = @_;
  24         my $self = Redis->new;
  25         $name .= ':' if $name;
  26         $self->{name} = $name || '';
  27         bless $self => $class;
  28 }
  29
  30 sub STORE {
  31         my ($self,$key,$value) = @_;
  32         $self->set( $self->{name} . $key, $value );
  33 }
  34
  35 sub FETCH {
  36         my ($self,$key) = @_;
  37         $self->get( $self->{name} . $key );
  38 }
  39
  40 sub FIRSTKEY {
  41         my $self = shift;
  42         $self->{keys} = [ $self->keys( $self->{name} . '*' ) ];
  43         $self->NEXTKEY;
  44 }
  45
  46 sub NEXTKEY {
  47         my $self = shift;
  48         my $key = shift @{ $self->{keys} } || return;
  49         my $name = $self->{name};
  50         $key =~ s{^$name}{} || warn "can't strip $name from $key";
  51         return $key;
  52 }
  53
  54 sub EXISTS {
  55         my ($self,$key) = @_;
  56         $self->exists( $self->{name} . $key );
  57 }
  58
  59 sub DELETE {
  60         my ($self,$key) = @_;
  61         $self->del( $self->{name} . $key );
  62 }
  63
  64 sub CLEAR {
  65         my ($self) = @_;
  66         $self->del( $_ ) foreach ( $self->keys( $self->{name} . '*' ) );
  67         $self->{keys} = [];
  68 }
  69
  70 1;