X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=lib%2FRedis.pm;h=ef4e53c17c57543ffc228997c0afe7eec785fb6c;hb=0f371f4ddc5245fa9f596c3f19eade4b36589e68;hp=70df1ef0146b4d8840bcec6277197563636a4d7c;hpb=5a3c0198879093b421c664c381d4bdc6a68eb1e8;p=perl-Redis.git diff --git a/lib/Redis.pm b/lib/Redis.pm index 70df1ef..ef4e53c 100644 --- a/lib/Redis.pm +++ b/lib/Redis.pm @@ -4,444 +4,455 @@ use warnings; use strict; use IO::Socket::INET; -use Data::Dump qw/dump/; +use Fcntl qw( O_NONBLOCK F_SETFL ); +use Data::Dumper; use Carp qw/confess/; +use Encode; =head1 NAME -Redis - The great new Redis! +Redis - perl binding for Redis database =cut -our $VERSION = '0.01'; +our $VERSION = '1.2001'; -=head1 SYNOPSIS +=head1 DESCRIPTION Pure perl bindings for L - use Redis; - - my $r = Redis->new(); - +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 -=cut + my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379 -our $sock; -my $server = '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 = {}; - bless($self, $class); + my $class = shift; + my $self = {@_}; - warn "# opening socket to $server"; + $self->{debug} ||= $ENV{REDIS_DEBUG}; + $self->{encoding} ||= 'utf8'; ## default to lax utf8 - $sock ||= IO::Socket::INET->new( - PeerAddr => $server, - Proto => 'tcp', - ) || die $!; + $self->{server} ||= $ENV{REDIS_SERVER} || '127.0.0.1:6379'; + $self->{sock} = IO::Socket::INET->new( + PeerAddr => $self->{server}, + Proto => 'tcp', + ) || confess("Could not connect to Redis server at $self->{server}: $!"); - $self; -} + $self->{read_size} = 8192; + $self->{rbuf} = ''; -sub _sock_result { - my $result = <$sock>; - warn "# result: ",dump( $result ); - $result =~ s{\r\n$}{} || warn "can't find cr/lf"; - return $result; -} + $self->{is_subscriber} = 0; -sub _sock_read_bulk { - my $len = <$sock>; - warn "## bulk len: ",dump($len); - return undef if $len eq "nil\r\n"; - my $v; - if ( $len > 0 ) { - read($sock, $v, $len) || die $!; - warn "## bulk v: ",dump($v); - } - my $crlf; - read($sock, $crlf, 2); # skip cr/lf - return $v; + return bless($self, $class); } -sub _sock_result_bulk { - my $self = shift; - warn "## _sock_result_bulk ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - _sock_read_bulk(); -} -sub __sock_ok { - my $ok = <$sock>; - return undef if $ok eq "nil\r\n"; - confess dump($ok) unless $ok eq "+OK\r\n"; -} +### we don't want DESTROY to fallback into AUTOLOAD +sub DESTROY { } -sub _sock_send { - my $self = shift; - warn "## _sock_send ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - _sock_result(); -} -sub _sock_send_ok { - my $self = shift; - warn "## _sock_send_ok ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - __sock_ok(); -} +### Deal with common, general case, Redis commands +our $AUTOLOAD; + +sub AUTOLOAD { + my $self = shift; + my $sock = $self->{sock} || confess("Not connected to any server"); + my $enc = $self->{encoding}; + my $deb = $self->{debug}; + + my $command = $AUTOLOAD; + $command =~ s/.*://; + $self->__is_valid_command($command); -sub __sock_send_bulk_raw { - my $self = shift; - warn "## _sock_send_bulk ",dump( @_ ); - my $value = pop; - $value = '' unless defined $value; # FIXME errr? nil? - print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n" + $self->__send_command($command, @_); + + return $self->__read_response($command); } -sub _sock_send_bulk { - __sock_send_bulk_raw( @_ ); - __sock_ok(); + +### Commands with extra logic +sub quit { + my ($self) = @_; + + $self->__send_command('QUIT'); + + close(delete $self->{sock}) || confess("Can't close socket: $!"); + delete $self->{rbuf}; + + return 1; } -sub _sock_send_bulk_number { - __sock_send_bulk_raw( @_ ); - my $v = _sock_result(); - confess $v unless $v =~ m{^\-?\d+$}; - return $v; +sub info { + my ($self) = @_; + $self->__is_valid_command('INFO'); + + $self->__send_command('INFO'); + + my $info = $self->__read_response('INFO'); + + return {map { split(/:/, $_, 2) } split(/\r\n/, $info)}; } +sub keys { + my $self = shift; + $self->__is_valid_command('KEYS'); + + $self->__send_command('KEYS', @_); + + my @keys = $self->__read_response('INFO', \my $type); + return @keys if $type eq '*'; + + ## Support redis <= 1.2.6 + return split(/\s/, $keys[0]) if $keys[0]; + return; +} + + +### Mode validation +sub __is_valid_command { + my ($self, $cmd) = @_; + + return unless $self->{is_subscriber}; + return if $cmd =~ /^P?(UN)?SUBSCRIBE$/i; + confess("Cannot use command '$cmd' while in SUBSCRIBE mode, "); +} + + +### Socket operations +sub __send_command { + my $self = shift; + my $cmd = uc(shift); + my $enc = $self->{encoding}; + my $deb = $self->{debug}; + + warn "[SEND] $cmd ", Dumper([@_]) if $deb; + + ## Encode command using multi-bulk format + my $n_elems = scalar(@_) + 1; + my $buf = "\*$n_elems\r\n"; + for my $elem ($cmd, @_) { + my $bin = $enc ? encode($enc, $elem) : $elem; + $buf .= defined($bin) ? '$' . length($bin) . "\r\n$bin\r\n" : "\$-1\r\n"; + } + + ## Send command, take care for partial writes + warn "[SEND RAW] $buf" if $deb; + my $sock = $self->{sock} || confess("Not connected to any server"); + while ($buf) { + my $len = syswrite $sock, $buf, length $buf; + confess("Could not write to Redis server: $!") + unless $len; + substr $buf, 0, $len, ""; + } + + return; +} + +sub __read_response { + my ($self, $command, $type_r) = @_; + + my ($type, $result) = $self->__read_sock; + $$type_r = $type if $type_r; + + if ($type eq '-') { + confess "[$command] $result, "; + } + elsif ($type eq '+') { + return $result; + } + elsif ($type eq '$') { + return if $result < 0; + return $self->__read_sock($result); + } + elsif ($type eq '*') { + my @list; + while ($result--) { + push @list, $self->__read_response($command); + } + return @list; + } + elsif ($type eq ':') { + return $result; + } + else { + confess "unknown answer type: $type ($result), "; + } +} + +sub __read_sock { + my ($self, $len) = @_; + my $sock = $self->{sock} || confess("Not connected to any server"); + my $enc = $self->{encoding}; + my $deb = $self->{debug}; + my $rbuf = \($self->{rbuf}); + + my ($data, $type) = ('', ''); + my $read_size = $self->{read_size}; + $read_size = $len + 2 if defined $len && $len + 2 > $read_size; + + while (1) { + ## Read NN bytes, strip \r\n at the end + if (defined $len) { + if (length($$rbuf) >= $len + 2) { + $data = substr(substr($$rbuf, 0, $len + 2, ''), 0, -2); + last; + } + } + ## No len, means line more, read until \r\n + elsif ($$rbuf =~ s/^(.)([^\015\012]*)\015\012//) { + ($type, $data) = ($1, $2); + last; + } + + my $bytes = sysread $sock, $$rbuf, $read_size, length $$rbuf; + confess("Error while reading from Redis server: $!") + unless defined $bytes; + confess("Redis server closed connection") unless $bytes; + } + + $data = decode($enc, $data) if $enc; + warn "[RECV] '$type$data'" if $self->{debug}; + + return ($type, $data) if $type; + return $data; +} + +sub __can_read_sock { + my ($self) = @_; + my $sock = $self->{sock}; + my $rbuf = \($self->{rbuf}); + + return 1 if $$rbuf; + __fh_nonblocking($sock, 1); + my $bytes = sysread $sock, $$rbuf, $self->{read_size}, length $$rbuf; + __fh_nonblocking($sock, 0); + return 1 if $bytes; + return 0; +} + + +### Copied from AnyEvent::Util +BEGIN { + *__fh_nonblocking = ($^O eq 'MSWin32') + ? sub($$) { ioctl $_[0], 0x8004667e, pack "L", $_[1]; } # FIONBIO + : sub($$) { fcntl $_[0], F_SETFL, $_[1] ? O_NONBLOCK : 0; }; +} + + +1; + +__END__ + =head1 Connection Handling =head2 quit $r->quit; -=cut - -sub quit { - my $self = shift; - - close( $sock ) || warn $!; -} - =head2 ping $r->ping || die "no server?"; -=cut - -sub ping { - print $sock "PING\r\n"; - my $pong = <$sock>; - die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n"; -} - =head1 Commands operating on string values =head2 set - $r->set( foo => 'bar', $new ); - -=cut + $r->set( foo => 'bar' ); -sub set { - my ( $self, $key, $value, $new ) = @_; - $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value ); -} + $r->setnx( foo => 42 ); =head2 get my $value = $r->get( 'foo' ); -=cut +=head2 mget -sub get { - my $self = shift; - $self->_sock_result_bulk('GET', @_); -} + my @values = $r->mget( 'foo', 'bar', 'baz' ); =head2 incr $r->incr('counter'); - $r->incr('tripplets', 3); -=cut - - - -sub incr { - my $self = shift; - $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ ); -} + $r->incrby('tripplets', 3); =head2 decr $r->decr('counter'); - $r->decr('tripplets', 3); - -=cut -sub decr { - my $self = shift; - $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ ); -} + $r->decrby('tripplets', 3); =head2 exists $r->exists( 'key' ) && print "got key!"; -=cut - -sub exists { - my ( $self, $key ) = @_; - $self->_sock_send( 'EXISTS', $key ); -} - =head2 del $r->del( 'key' ) || warn "key doesn't exist"; -=cut - -sub del { - my ( $self, $key ) = @_; - $self->_sock_send( 'DEL', $key ); -} - =head2 type $r->type( 'key' ); # = string -=cut - -sub type { - my ( $self, $key ) = @_; - $self->_sock_send( 'TYPE', $key ); -} - =head1 Commands operating on the key space =head2 keys my @keys = $r->keys( '*glob_pattern*' ); -=cut - -sub keys { - my ( $self, $glob ) = @_; - return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob )); -} - =head2 randomkey my $key = $r->randomkey; -=cut - -sub randomkey { - my ( $self ) = @_; - $self->_sock_send( 'RANDOMKEY' ); -} - =head2 rename my $ok = $r->rename( 'old-key', 'new-key', $new ); -=cut - -sub rename { - my ( $self, $old, $new, $nx ) = @_; - $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new ); -} - =head2 dbsize my $nr_keys = $r->dbsize; -=cut - -sub dbsize { - my ( $self ) = @_; - $self->_sock_send('DBSIZE'); -} - =head1 Commands operating on lists +See also L for tie interface. + =head2 rpush $r->rpush( $key, $value ); -=cut - -sub rpush { - my ( $self, $key, $value ) = @_; - $self->_sock_send_bulk('RPUSH', $key, $value); -} - =head2 lpush $r->lpush( $key, $value ); -=cut - -sub lpush { - my ( $self, $key, $value ) = @_; - $self->_sock_send_bulk('LPUSH', $key, $value); -} - =head2 llen $r->llen( $key ); -=cut - -sub llen { - my ( $self, $key ) = @_; - $self->_sock_send( 'LLEN', $key ); -} - =head2 lrange my @list = $r->lrange( $key, $start, $end ); -=cut +=head2 ltrim -sub lrange { - my ( $self, $key, $start, $end ) = @_; - my $size = $self->_sock_send('LRANGE', $key, $start, $end); + my $ok = $r->ltrim( $key, $start, $end ); - confess $size unless $size > 0; - $size--; +=head2 lindex - my @list = ( 0 .. $size ); - foreach ( 0 .. $size ) { - $list[ $_ ] = _sock_read_bulk(); - } + $r->lindex( $key, $index ); - warn "## lrange $key $start $end = [$size] ", dump( @list ); - return @list; -} +=head2 lset -=head2 ltrim + $r->lset( $key, $index, $value ); - my $ok = $r->ltrim( $key, $start, $end ); +=head2 lrem -=cut + my $modified_count = $r->lrem( $key, $count, $value ); -sub ltrim { - my ( $self, $key, $start, $end ) = @_; - $self->_sock_send_ok( 'LTRIM', $key, $start, $end ); -} +=head2 lpop -=head2 lindex + my $value = $r->lpop( $key ); - $r->lindex( $key, $index ); +=head2 rpop -=cut + my $value = $r->rpop( $key ); -sub lindex { - my ( $self, $key, $index ) = @_; - $self->_sock_result_bulk( 'LINDEX', $key, $index ); -} +=head1 Commands operating on sets -=head2 lset +=head2 sadd - $r->lset( $key, $index, $value ); + $r->sadd( $key, $member ); -=cut +=head2 srem -sub lset { - my ( $self, $key, $index, $value ) = @_; - $self->_sock_send_bulk( 'LSET', $key, $index, $value ); -} + $r->srem( $key, $member ); -=head2 lrem +=head2 scard - my $modified_count = $r->lrem( $key, $count, $value ); + my $elements = $r->scard( $key ); -=cut +=head2 sismember -sub lrem { - my ( $self, $key, $count, $value ) = @_; - $self->_sock_send_bulk_number( 'LREM', $key, $count, $value ); -} + $r->sismember( $key, $member ); -=head2 lpop +=head2 sinter - my $value = $r->lpop( $key ); + $r->sinter( $key1, $key2, ... ); -=cut +=head2 sinterstore -sub lpop { - my ( $self, $key ) = @_; - $self->_sock_result_bulk( 'LPOP', $key ); -} + my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... ); -=head2 rpop +=head1 Multiple databases handling commands - my $value = $r->rpop( $key ); +=head2 select -=cut + $r->select( $dbindex ); # 0 for new clients -sub rpop { - my ( $self, $key ) = @_; - $self->_sock_result_bulk( 'RPOP', $key ); -} +=head2 move -=head1 Commands operating on sets + $r->move( $key, $dbindex ); -=head2 sadd +=head2 flushdb - $r->sadd( $key, $member ); + $r->flushdb; -=cut +=head2 flushall -sub sadd { - my ( $self, $key, $member ) = @_; - $self->_sock_send_bulk_number( 'SADD', $key, $member ); -} + $r->flushall; -=head2 srem +=head1 Sorting - $r->srem( $key, $member ); +=head2 sort -=cut + $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA'); -sub srem { - my ( $self, $key, $member ) = @_; - $self->_sock_send_bulk_number( 'SREM', $key, $member ); -} +=head1 Persistence control commands -=head2 scard +=head2 save - my $elements = $r->scard( $key ); + $r->save; -=cut +=head2 bgsave -sub scard { - my ( $self, $key ) = @_; - $self->_sock_send( 'SCARD', $key ); -} + $r->bgsave; -=head2 sismember +=head2 lastsave - $r->sismember( $key, $member ); + $r->lastsave; -=cut +=head2 shutdown -sub sismember { - my ( $self, $key, $member ) = @_; - $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member ); -} + $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 @@ -461,6 +472,8 @@ automatically be notified of progress on your bug as I make changes. 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: @@ -491,7 +504,7 @@ L =head1 COPYRIGHT & LICENSE -Copyright 2009 Dobrica Pavlinusic, all rights reserved. +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.