From bc7a707890951a9cea371a1691fd15b055dbca1b Mon Sep 17 00:00:00 2001 From: Dobrica Pavlinusic Date: Tue, 24 Mar 2009 22:51:53 +0000 Subject: [PATCH] update bindings for new protocol 0.08 new protocol is self-describing, so all commands are now implemented using AUTOLOAD git-svn-id: svn+ssh://llin/home/dpavlin/private/svn/Redis@53 447b33ff-793d-4489-8442-9bea7d161be5 --- Changes | 3 + lib/Redis.pm | 468 ++++++++++++--------------------------------------- t/01-Redis.t | 7 +- 3 files changed, 113 insertions(+), 365 deletions(-) diff --git a/Changes b/Changes index 5a0af9b..876e71d 100644 --- a/Changes +++ b/Changes @@ -3,3 +3,6 @@ Revision history for Redis 0.01 Sun Mar 22 19:02:17 CET 2009 First version, tracking git://github.com/antirez/redis +0.08 Tue Mar 24 22:38:59 CET 2009 + This version supports new protocol introduced in beta 8 + Version bump to be in-sync with Redis version diff --git a/lib/Redis.pm b/lib/Redis.pm index 29c2746..a35d14e 100644 --- a/lib/Redis.pm +++ b/lib/Redis.pm @@ -13,24 +13,29 @@ Redis - perl binding for Redis database =cut -our $VERSION = '0.01'; +our $VERSION = '0.08'; -=head1 SYNOPSIS +=head1 DESCRIPTION Pure perl bindings for L -This version support git version of Redis available at -L +This version support git version 0.08 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 + my $r = Redis->new; + =cut our $debug = $ENV{REDIS} || 0; @@ -53,91 +58,119 @@ sub new { $self; } -sub __sock_result { - my $result = <$sock>; - warn "## result: ",dump( $result ) if $debug; - $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; + $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' ) { + return split(/\s/, __sock_read_bulk($result)); + } + + 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) if $debug; - return undef if $len eq "nil\r\n"; + my $len = shift; + return undef if $len < 0; + my $v; if ( $len > 0 ) { read($sock, $v, $len) || die $!; - warn "## bulk v: ",dump($v) if $debug; + 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( @_ ) if $debug; - print $sock join(' ',@_) . "\r\n"; - __sock_read_bulk(); -} +sub __sock_read_multi_bulk { + my $size = shift; + return undef if $size < 0; -sub _sock_result_bulk_list { - my $self = shift; - warn "## _sock_result_bulk_list ",dump( @_ ) if $debug; - - my $size = $self->_sock_send( @_ ); - confess $size unless $size > 0; $size--; my @list = ( 0 .. $size ); foreach ( 0 .. $size ) { - $list[ $_ ] = __sock_read_bulk(); + $list[ $_ ] = __sock_read_bulk( substr(<$sock>,1,-2) ); } warn "## list = ", dump( @list ) if $debug; return @list; } -sub __sock_ok { - my $ok = <$sock>; - return undef if $ok eq "nil\r\n"; - confess dump($ok) unless $ok eq "+OK\r\n"; -} +1; -sub _sock_send { - my $self = shift; - warn "## _sock_send ",dump( @_ ) if $debug; - print $sock join(' ',@_) . "\r\n"; - __sock_result(); -} - -sub _sock_send_ok { - my $self = shift; - warn "## _sock_send_ok ",dump( @_ ) if $debug; - print $sock join(' ',@_) . "\r\n"; - __sock_ok(); -} - -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(); -} - -sub _sock_send_bulk_number { - my $self = shift; - __sock_send_bulk_raw( @_ ); - my $v = __sock_result(); - confess $v unless $v =~ m{^\-?\d+$}; - return $v; -} +__END__ =head1 Connection Handling @@ -145,168 +178,68 @@ 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 ); + $r->set( foo => 'bar' ); -=cut - -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 - -sub get { - my $self = shift; - $self->_sock_result_bulk('GET',@_); -} - =head2 mget - my @values = $r->get( 'foo', 'bar', 'baz' ); - -=cut - -sub mget { - my $self = shift; - $self->_sock_result_bulk_list('MGET',@_); -} + 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 ) = @_; - my $keys = $self->_sock_result_bulk( 'KEYS', $glob ); - return split(/\s/, $keys) if $keys; - return () if wantarray; -} - =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. @@ -315,305 +248,116 @@ 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 - -sub move { - my ( $self, $key, $dbindex ) = @_; - $self->_sock_send( 'MOVE', $key, $dbindex ); -} - =head2 flushdb $r->flushdb; -=cut - -sub flushdb { - my $self = shift; - $self->_sock_send_ok('FLUSHDB'); -} - =head2 flushall $r->flushall; -=cut - -sub flushall { - my $self = shift; - $self->_sock_send_ok('flushall'); -} - =head1 Sorting =head2 sort $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA'); -=cut - -sub sort { - my ( $self, $sort ) = @_; - $self->_sock_result_bulk_list( "SORT $sort" ); -} - =head1 Persistence control commands =head2 save $r->save; -=cut - -sub save { - my $self = shift; - $self->_sock_send_ok( 'SAVE' ); -} - =head2 bgsave $r->bgsave; -=cut - -sub bgsave { - my $self = shift; - $self->_sock_send_ok( 'BGSAVE' ); -} - =head2 lastsave $r->lastsave; -=cut - -sub lastsave { - my $self = shift; - $self->_sock_send( 'LASTSAVE' ); -} - =head2 shutdown $r->shutdown; -=cut - -sub shutdown { - my $self = shift; - $self->_sock_send( 'SHUTDOWN' ); -} - =head1 Remote server control commands =head2 info my $info_hash = $r->info; -=cut - -sub info { - my $self = shift; - my $info = $self->_sock_result_bulk( 'INFO' ); - my $hash; - foreach my $l ( split(/\r\n/, $info ) ) { - my ($n,$v) = split(/:/, $l, 2); - $hash->{$n} = $v; - } - return $hash; -} - =head1 AUTHOR Dobrica Pavlinusic, C<< >> @@ -632,6 +376,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: diff --git a/t/01-Redis.t b/t/01-Redis.t index 211f743..2724411 100755 --- a/t/01-Redis.t +++ b/t/01-Redis.t @@ -21,8 +21,7 @@ diag "Commands operating on string values"; ok( $o->set( foo => 'bar' ), 'set foo => bar' ); -eval { $o->set( foo => 'bar', 1 ) }; -ok( $@, 'set foo => bar new again failed' ); +ok( ! $o->setnx( foo => 'bar' ), 'setnx foo => bar fails' ); cmp_ok( $o->get( 'foo' ), 'eq', 'bar', 'get foo = bar' ); @@ -65,8 +64,8 @@ cmp_ok( $o->get( 'key-next' ), '==', $key_next + 1, 'key-next' ); ok( $o->set('test-incrby', 0), 'test-incrby' ); ok( $o->set('test-decrby', 0), 'test-decry' ); foreach ( 1 .. 3 ) { - cmp_ok( $o->incr('test-incrby', 3), '==', $_ * 3, 'incrby 3' ); - cmp_ok( $o->decr('test-decrby', 7), '==', -( $_ * 7 ), 'decrby 7' ); + cmp_ok( $o->incrby('test-incrby', 3), '==', $_ * 3, 'incrby 3' ); + cmp_ok( $o->decrby('test-decrby', 7), '==', -( $_ * 7 ), 'decrby 7' ); } ok( $o->del( $_ ), "del $_" ) foreach map { "key-$_" } ( 'next', 'left' ); -- 2.20.1