package Redis;
use warnings;
use strict;
use IO::Socket::INET;
use Data::Dumper;
use Carp qw/confess/;
use Encode;
=head1 NAME
Redis - perl binding for Redis database
=cut
our $VERSION = '1.2001';
=head1 DESCRIPTION
Pure perl bindings for L
This version supports protocol 1.2 or later of Redis available at
L
This documentation
lists commands which are exercised in test suite, but
additinal commands will work correctly since protocol
specifies enough information to support almost all commands
with same peace of code with a little help of C.
=head1 FUNCTIONS
=head2 new
my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
=cut
sub new {
my $class = shift;
my $self = {@_};
$self->{debug} ||= $ENV{REDIS_DEBUG};
$self->{sock} = IO::Socket::INET->new(
PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
Proto => 'tcp',
) || die $!;
bless($self, $class);
$self;
}
my $bulk_command = {
set => 1, setnx => 1,
rpush => 1, lpush => 1,
lset => 1, lrem => 1,
sadd => 1, srem => 1,
sismember => 1,
echo => 1,
getset => 1,
smove => 1,
zadd => 1,
zrem => 1,
zscore => 1,
zincrby => 1,
append => 1,
};
# we don't want DESTROY to fallback into AUTOLOAD
sub DESTROY {}
our $AUTOLOAD;
sub AUTOLOAD {
my $self = shift;
use bytes;
my $sock = $self->{sock} || die "no server connected";
my $command = $AUTOLOAD;
$command =~ s/.*://;
warn "## $command ",Dumper(@_) if $self->{debug};
my $send;
if ( defined $bulk_command->{$command} ) {
my $value = pop;
$value = '' if ! defined $value;
$send
= uc($command)
. ' '
. join(' ', @_)
. ' '
. length( $value )
. "\r\n$value\r\n"
;
} else {
$send
= uc($command)
. ' '
. join(' ', @_)
. "\r\n"
;
}
warn ">> $send" if $self->{debug};
print $sock $send;
if ( $command eq 'quit' ) {
close( $sock ) || die "can't close socket: $!";
return 1;
}
my $result = <$sock> || die "can't read socket: $!";
Encode::_utf8_on($result);
warn "<< $result" if $self->{debug};
my $type = substr($result,0,1);
$result = substr($result,1,-2);
if ( $command eq 'info' ) {
my $hash;
foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
my ($n,$v) = split(/:/, $l, 2);
$hash->{$n} = $v;
}
return $hash;
} elsif ( $command eq 'keys' ) {
my $keys = $self->__read_bulk($result);
return split(/\s/, $keys) if $keys;
return;
}
if ( $type eq '-' ) {
confess "[$command] $result";
} elsif ( $type eq '+' ) {
return $result;
} elsif ( $type eq '$' ) {
return $self->__read_bulk($result);
} elsif ( $type eq '*' ) {
return $self->__read_multi_bulk($result);
} elsif ( $type eq ':' ) {
return $result; # FIXME check if int?
} else {
confess "unknown type: $type", $self->__read_line();
}
}
sub __read_bulk {
my ($self,$len) = @_;
return if $len < 0;
my $v;
if ( $len > 0 ) {
read($self->{sock}, $v, $len) || die $!;
Encode::_utf8_on($v);
warn "<< ",Dumper($v),$/ if $self->{debug};
}
my $crlf;
read($self->{sock}, $crlf, 2); # skip cr/lf
return $v;
}
sub __read_multi_bulk {
my ($self,$size) = @_;
return if $size < 0;
my $sock = $self->{sock};
$size--;
my @list = ( 0 .. $size );
foreach ( 0 .. $size ) {
$list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
}
warn "## list = ", Dumper( @list ) if $self->{debug};
return @list;
}
1;
__END__
=head1 Connection Handling
=head2 quit
$r->quit;
=head2 ping
$r->ping || die "no server?";
=head1 Commands operating on string values
=head2 set
$r->set( foo => 'bar' );
$r->setnx( foo => 42 );
=head2 get
my $value = $r->get( 'foo' );
=head2 mget
my @values = $r->mget( 'foo', 'bar', 'baz' );
=head2 incr
$r->incr('counter');
$r->incrby('tripplets', 3);
=head2 decr
$r->decr('counter');
$r->decrby('tripplets', 3);
=head2 exists
$r->exists( 'key' ) && print "got key!";
=head2 del
$r->del( 'key' ) || warn "key doesn't exist";
=head2 type
$r->type( 'key' ); # = string
=head1 Commands operating on the key space
=head2 keys
my @keys = $r->keys( '*glob_pattern*' );
=head2 randomkey
my $key = $r->randomkey;
=head2 rename
my $ok = $r->rename( 'old-key', 'new-key', $new );
=head2 dbsize
my $nr_keys = $r->dbsize;
=head1 Commands operating on lists
See also L for tie interface.
=head2 rpush
$r->rpush( $key, $value );
=head2 lpush
$r->lpush( $key, $value );
=head2 llen
$r->llen( $key );
=head2 lrange
my @list = $r->lrange( $key, $start, $end );
=head2 ltrim
my $ok = $r->ltrim( $key, $start, $end );
=head2 lindex
$r->lindex( $key, $index );
=head2 lset
$r->lset( $key, $index, $value );
=head2 lrem
my $modified_count = $r->lrem( $key, $count, $value );
=head2 lpop
my $value = $r->lpop( $key );
=head2 rpop
my $value = $r->rpop( $key );
=head1 Commands operating on sets
=head2 sadd
$r->sadd( $key, $member );
=head2 srem
$r->srem( $key, $member );
=head2 scard
my $elements = $r->scard( $key );
=head2 sismember
$r->sismember( $key, $member );
=head2 sinter
$r->sinter( $key1, $key2, ... );
=head2 sinterstore
my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
=head1 Multiple databases handling commands
=head2 select
$r->select( $dbindex ); # 0 for new clients
=head2 move
$r->move( $key, $dbindex );
=head2 flushdb
$r->flushdb;
=head2 flushall
$r->flushall;
=head1 Sorting
=head2 sort
$r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
=head1 Persistence control commands
=head2 save
$r->save;
=head2 bgsave
$r->bgsave;
=head2 lastsave
$r->lastsave;
=head2 shutdown
$r->shutdown;
=head1 Remote server control commands
=head2 info
my $info_hash = $r->info;
=head1 ENCODING
Since Redis knows nothing about encoding, we are forcing utf-8 flag on all data received from Redis.
This change is introduced in 1.2001 version.
This allows us to round-trip utf-8 encoded characters correctly, but might be problem if you push
binary junk into Redis and expect to get it back without utf-8 flag turned on.
=head1 AUTHOR
Dobrica Pavlinusic, C<< >>
=head1 BUGS
Please report any bugs or feature requests to C, or through
the web interface at L. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc Redis
perldoc Redis::List
perldoc Redis::Hash
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L
=item * AnnoCPAN: Annotated CPAN documentation
L
=item * CPAN Ratings
L
=item * Search CPAN
L
=back
=head1 ACKNOWLEDGEMENTS
=head1 COPYRIGHT & LICENSE
Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of Redis