X-Git-Url: http://git.rot13.org/?p=perl-Redis.git;a=blobdiff_plain;f=lib%2FRedis.pm;h=6a6d278983772b24bf26ad9c5e312c0050dab067;hp=70df1ef0146b4d8840bcec6277197563636a4d7c;hb=24aed6f30fef226076cf963d6407151e6eb082e5;hpb=5a3c0198879093b421c664c381d4bdc6a68eb1e8 diff --git a/lib/Redis.pm b/lib/Redis.pm index 70df1ef..6a6d278 100644 --- a/lib/Redis.pm +++ b/lib/Redis.pm @@ -9,30 +9,37 @@ use Carp qw/confess/; =head1 NAME -Redis - The great new Redis! +Redis - perl binding for Redis database =cut -our $VERSION = '0.01'; +our $VERSION = '0.08'; -=head1 SYNOPSIS +=head1 DESCRIPTION Pure perl bindings for L - use Redis; - - my $r = Redis->new(); - +This version support git version 0.08 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; + =cut +our $debug = $ENV{REDIS} || 0; + our $sock; my $server = '127.0.0.1:6379'; @@ -51,73 +58,122 @@ sub new { $self; } -sub _sock_result { - my $result = <$sock>; - warn "# result: ",dump( $result ); - $result =~ s{\r\n$}{} || warn "can't find cr/lf"; - return $result; +my $bulk_command = { + set => 1, setnx => 1, + rpush => 1, lpush => 1, + lset => 1, lrem => 1, + sadd => 1, srem => 1, + sismember => 1, + echo => 1, +}; + +# we don't want DESTROY to fallback into AUTOLOAD +sub DESTROY {} + +our $AUTOLOAD; +sub AUTOLOAD { + my $self = shift; + + my $command = $AUTOLOAD; + $command =~ s/.*://; + + warn "## $command ",dump(@_) if $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 $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: $!"; + warn "<< $result" if $debug; + my $type = substr($result,0,1); + $result = substr($result,1,-2); + + if ( $command eq 'info' ) { + my $hash; + foreach my $l ( split(/\r\n/, __sock_read_bulk($result) ) ) { + my ($n,$v) = split(/:/, $l, 2); + $hash->{$n} = $v; + } + return $hash; + } elsif ( $command eq 'keys' ) { + my $keys = __sock_read_bulk($result); + return split(/\s/, $keys) if $keys; + return; + } + + if ( $type eq '-' ) { + confess $result; + } elsif ( $type eq '+' ) { + return $result; + } elsif ( $type eq '$' ) { + return __sock_read_bulk($result); + } elsif ( $type eq '*' ) { + return __sock_read_multi_bulk($result); + } elsif ( $type eq ':' ) { + return $result; # FIXME check if int? + } else { + confess "unknown type: $type", __sock_read_line(); + } } -sub _sock_read_bulk { - my $len = <$sock>; - warn "## bulk len: ",dump($len); - return undef if $len eq "nil\r\n"; +sub __sock_read_bulk { + my $len = shift; + return undef if $len < 0; + my $v; if ( $len > 0 ) { read($sock, $v, $len) || die $!; - warn "## bulk v: ",dump($v); + warn "<< ",dump($v),$/ if $debug; } my $crlf; read($sock, $crlf, 2); # skip cr/lf return $v; } -sub _sock_result_bulk { - my $self = shift; - warn "## _sock_result_bulk ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - _sock_read_bulk(); -} +sub __sock_read_multi_bulk { + my $size = shift; + return undef if $size < 0; -sub __sock_ok { - my $ok = <$sock>; - return undef if $ok eq "nil\r\n"; - confess dump($ok) unless $ok eq "+OK\r\n"; -} - -sub _sock_send { - my $self = shift; - warn "## _sock_send ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - _sock_result(); -} + $size--; -sub _sock_send_ok { - my $self = shift; - warn "## _sock_send_ok ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - __sock_ok(); -} + my @list = ( 0 .. $size ); + foreach ( 0 .. $size ) { + $list[ $_ ] = __sock_read_bulk( substr(<$sock>,1,-2) ); + } -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" + warn "## list = ", dump( @list ) if $debug; + return @list; } -sub _sock_send_bulk { - __sock_send_bulk_raw( @_ ); - __sock_ok(); -} +1; -sub _sock_send_bulk_number { - __sock_send_bulk_raw( @_ ); - my $v = _sock_result(); - confess $v unless $v =~ m{^\-?\d+$}; - return $v; -} +__END__ =head1 Connection Handling @@ -125,323 +181,185 @@ sub _sock_send_bulk_number { $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 AUTHOR @@ -461,6 +379,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: