X-Git-Url: http://git.rot13.org/?p=perl-Redis.git;a=blobdiff_plain;f=lib%2FRedis.pm;h=6ead5dee4437e18d275233c0a68479752253a46e;hp=c976c6b871b9d678e7365ec5c388898e9fc3377f;hb=776f1916034f293af03303fb23d65c04c62ec352;hpb=c34a5050d658b02796e60d898929ef1690c9c00f diff --git a/lib/Redis.pm b/lib/Redis.pm index c976c6b..6ead5de 100644 --- a/lib/Redis.pm +++ b/lib/Redis.pm @@ -3,13 +3,13 @@ package Redis; use warnings; use strict; -=head1 NAME - -Redis - The great new Redis! +use IO::Socket::INET; +use Data::Dump qw/dump/; +use Carp qw/confess/; -=head1 VERSION +=head1 NAME -Version 0.01 +Redis - perl binding for Redis database =cut @@ -18,34 +18,548 @@ our $VERSION = '0.01'; =head1 SYNOPSIS -Quick summary of what the module does. +Pure perl bindings for L -Perhaps a little code snippet. +This version support git version of Redis available at +L use Redis; - my $foo = Redis->new(); - ... + my $r = Redis->new(); + +=head1 FUNCTIONS + +=head2 new -=head1 EXPORT +=cut -A list of functions that can be exported. You can delete this section -if you don't export anything, such as for a purely object-oriented module. +our $debug = $ENV{REDIS} || 0; -=head1 FUNCTIONS +our $sock; +my $server = '127.0.0.1:6379'; + +sub new { + my $class = shift; + my $self = {}; + bless($self, $class); + + warn "# opening socket to $server"; + + $sock ||= IO::Socket::INET->new( + PeerAddr => $server, + Proto => 'tcp', + ) || die $!; + + $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; +} + +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; +} + +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; + + my $size = $self->_sock_send( @_ ); + confess $size unless $size > 0; + $size--; + + my @list = ( 0 .. $size ); + foreach ( 0 .. $size ) { + $list[ $_ ] = __sock_read_bulk(); + } + + 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"; +} + +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; +} + +=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 + +sub set { + my ( $self, $key, $value, $new ) = @_; + $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value ); +} + +=head2 get + + my $value = $r->get( 'foo' ); + +=cut + +sub get { + my $self = shift; + $self->_sock_result_bulk('GET',@_); +} + +=head2 mget -=head2 function1 + my @values = $r->get( 'foo', 'bar', 'baz' ); =cut -sub function1 { +sub mget { + my $self = shift; + $self->_sock_result_bulk_list('MGET',@_); } -=head2 function2 +=head2 incr + + $r->incr('counter'); + $r->incr('tripplets', 3); + +=cut + + + +sub incr { + my $self = shift; + $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ ); +} + +=head2 decr + + $r->decr('counter'); + $r->decr('tripplets', 3); + +=cut + +sub decr { + my $self = shift; + $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ ); +} + +=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. + +=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 + +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 function2 { +sub save { + my $self = shift; + $self->_sock_send_ok( 'SAVE' ); } =head1 AUTHOR