X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=lib%2FRedis.pm;h=ef4e53c17c57543ffc228997c0afe7eec785fb6c;hb=0f371f4ddc5245fa9f596c3f19eade4b36589e68;hp=267fcc2e61c50e6dcad7338bc543202040496b35;hpb=64af4a24c8afba6e53561caa02d0c0f840c14dda;p=perl-Redis.git diff --git a/lib/Redis.pm b/lib/Redis.pm index 267fcc2..ef4e53c 100644 --- a/lib/Redis.pm +++ b/lib/Redis.pm @@ -4,8 +4,10 @@ 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 @@ -13,287 +15,319 @@ Redis - perl binding for Redis database =cut -our $VERSION = '0.01'; +our $VERSION = '1.2001'; -=head1 SYNOPSIS +=head1 DESCRIPTION Pure perl bindings for L -This version support git version of Redis available at -L +This version supports protocol 1.2 or later of Redis available at - use Redis; +L - my $r = Redis->new(); +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 $debug = $ENV{REDIS} || 0; + my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 ); -our $sock; -my $server = '127.0.0.1:6379'; +=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 ) if $debug; - $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) if $debug; - return undef if $len eq "nil\r\n"; - my $v; - if ( $len > 0 ) { - read($sock, $v, $len) || die $!; - warn "## bulk v: ",dump($v) if $debug; - } - 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( @_ ) if $debug; - print $sock join(' ',@_) . "\r\n"; - __sock_read_bulk(); -} -sub _sock_result_bulk_list { - my $self = shift; - warn "## _sock_result_bulk_list ",dump( @_ ) if $debug; +### we don't want DESTROY to fallback into AUTOLOAD +sub DESTROY { } - my $size = $self->_sock_send( @_ ); - confess $size unless $size > 0; - $size--; - my @list = ( 0 .. $size ); - foreach ( 0 .. $size ) { - $list[ $_ ] = __sock_read_bulk(); - } +### Deal with common, general case, Redis commands +our $AUTOLOAD; - warn "## list = ", dump( @list ) if $debug; - return @list; -} +sub AUTOLOAD { + my $self = shift; + my $sock = $self->{sock} || confess("Not connected to any server"); + my $enc = $self->{encoding}; + my $deb = $self->{debug}; -sub __sock_ok { - my $ok = <$sock>; - return undef if $ok eq "nil\r\n"; - confess dump($ok) unless $ok eq "+OK\r\n"; -} + my $command = $AUTOLOAD; + $command =~ s/.*://; + $self->__is_valid_command($command); -sub _sock_send { - my $self = shift; - warn "## _sock_send ",dump( @_ ) if $debug; - print $sock join(' ',@_) . "\r\n"; - __sock_result(); -} + $self->__send_command($command, @_); -sub _sock_send_ok { - my $self = shift; - warn "## _sock_send_ok ",dump( @_ ) if $debug; - print $sock join(' ',@_) . "\r\n"; - __sock_ok(); + return $self->__read_response($command); } -sub __sock_send_bulk_raw { - warn "## _sock_send_bulk ",dump( @_ ) if $debug; - my $value = pop; - $value = '' unless defined $value; # FIXME errr? nil? - print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n" -} -sub _sock_send_bulk { - my $self = shift; - __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 { - my $self = shift; - __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. @@ -302,204 +336,123 @@ See also L for tie interface. $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 - -sub lrange { - my ( $self, $key, $start, $end ) = @_; - $self->_sock_result_bulk_list('LRANGE', $key, $start, $end); -} - =head2 ltrim my $ok = $r->ltrim( $key, $start, $end ); -=cut - -sub ltrim { - my ( $self, $key, $start, $end ) = @_; - $self->_sock_send_ok( 'LTRIM', $key, $start, $end ); -} - =head2 lindex $r->lindex( $key, $index ); -=cut - -sub lindex { - my ( $self, $key, $index ) = @_; - $self->_sock_result_bulk( 'LINDEX', $key, $index ); -} - =head2 lset $r->lset( $key, $index, $value ); -=cut - -sub lset { - my ( $self, $key, $index, $value ) = @_; - $self->_sock_send_bulk( 'LSET', $key, $index, $value ); -} - =head2 lrem my $modified_count = $r->lrem( $key, $count, $value ); -=cut - -sub lrem { - my ( $self, $key, $count, $value ) = @_; - $self->_sock_send_bulk_number( 'LREM', $key, $count, $value ); -} - =head2 lpop my $value = $r->lpop( $key ); -=cut - -sub lpop { - my ( $self, $key ) = @_; - $self->_sock_result_bulk( 'LPOP', $key ); -} - =head2 rpop my $value = $r->rpop( $key ); -=cut - -sub rpop { - my ( $self, $key ) = @_; - $self->_sock_result_bulk( 'RPOP', $key ); -} - =head1 Commands operating on sets =head2 sadd $r->sadd( $key, $member ); -=cut - -sub sadd { - my ( $self, $key, $member ) = @_; - $self->_sock_send_bulk_number( 'SADD', $key, $member ); -} - =head2 srem $r->srem( $key, $member ); -=cut - -sub srem { - my ( $self, $key, $member ) = @_; - $self->_sock_send_bulk_number( 'SREM', $key, $member ); -} - =head2 scard my $elements = $r->scard( $key ); -=cut - -sub scard { - my ( $self, $key ) = @_; - $self->_sock_send( 'SCARD', $key ); -} - =head2 sismember $r->sismember( $key, $member ); -=cut - -sub sismember { - my ( $self, $key, $member ) = @_; - $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member ); -} - =head2 sinter $r->sinter( $key1, $key2, ... ); -=cut - -sub sinter { - my $self = shift; - $self->_sock_result_bulk_list( 'SINTER', @_ ); -} - =head2 sinterstore my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... ); -=cut - -sub sinterstore { - my $self = shift; - $self->_sock_send_ok( 'SINTERSTORE', @_ ); -} - =head1 Multiple databases handling commands =head2 select $r->select( $dbindex ); # 0 for new clients -=cut - -sub select { - my ($self,$dbindex) = @_; - confess dump($dbindex) . 'not number' unless $dbindex =~ m{^\d+$}; - $self->_sock_send_ok( 'SELECT', $dbindex ); -} - =head2 move $r->move( $key, $dbindex ); -=cut +=head2 flushdb -sub move { - my ( $self, $key, $dbindex ) = @_; - $self->_sock_send( 'MOVE', $key, $dbindex ); -} + $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 @@ -519,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: @@ -549,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.