X-Git-Url: http://git.rot13.org/?p=perl-Redis.git;a=blobdiff_plain;f=lib%2FRedis.pm;h=8df6779a2d5b1ed08a897aaaedebcffa27a81bd0;hp=745d9adc041fd615f5945ee927d738948ca8442a;hb=HEAD;hpb=96778b62304a7d787a721d6a5a56da60b7717c35 diff --git a/lib/Redis.pm b/lib/Redis.pm index 745d9ad..8df6779 100644 --- a/lib/Redis.pm +++ b/lib/Redis.pm @@ -4,238 +4,381 @@ use warnings; use strict; use IO::Socket::INET; -use Data::Dump qw/dump/; +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); - - warn "# opening socket to $server"; + my $self = {@_}; + $self->{debug} ||= $ENV{REDIS_DEBUG}; - $sock ||= IO::Socket::INET->new( - PeerAddr => $server, + $self->{sock} = IO::Socket::INET->new( + PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379', Proto => 'tcp', ) || die $!; + bless($self, $class); $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, + getset => 1, + smove => 1, + zadd => 1, + zrem => 1, + zscore => 1, + zincrby => 1, + append => 1, +}; + +# we don't want DESTROY to fallback into AUTOLOAD +sub DESTROY {} + +our $AUTOLOAD; +sub AUTOLOAD { + my $self = shift; + + use bytes; + + my $sock = $self->{sock} || die "no server connected"; + + my $command = $AUTOLOAD; + $command =~ s/.*://; + + warn "## $command ",Dumper(@_) if $self->{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 $self->{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: $!"; + Encode::_utf8_on($result); + warn "<< $result" if $self->{debug}; + my $type = substr($result,0,1); + $result = substr($result,1,-2); + + if ( $command eq 'info' ) { + my $hash; + foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) { + my ($n,$v) = split(/:/, $l, 2); + $hash->{$n} = $v; + } + return $hash; + } elsif ( $command eq 'keys' ) { + my $keys = $self->__read_bulk($result); + return split(/\s/, $keys) if $keys; + return; + } + + if ( $type eq '-' ) { + confess "[$command] $result"; + } elsif ( $type eq '+' ) { + return $result; + } elsif ( $type eq '$' ) { + return $self->__read_bulk($result); + } elsif ( $type eq '*' ) { + return $self->__read_multi_bulk($result); + } elsif ( $type eq ':' ) { + return $result; # FIXME check if int? + } else { + confess "unknown type: $type", $self->__read_line(); + } } -sub _sock_result_bulk { - my $len = <$sock>; - warn "# len: ",dump($len); - return undef if $len eq "nil\r\n"; +sub __read_bulk { + my ($self,$len) = @_; + return if $len < 0; + my $v; - read($sock, $v, $len) || die $!; - warn "# v: ",dump($v); + if ( $len > 0 ) { + read($self->{sock}, $v, $len) || die $!; + Encode::_utf8_on($v); + warn "<< ",Dumper($v),$/ if $self->{debug}; + } my $crlf; - read($sock, $crlf, 2); # skip cr/lf + read($self->{sock}, $crlf, 2); # skip cr/lf return $v; } -sub _sock_ok { - my $ok = <$sock>; - confess dump($ok) unless $ok eq "+OK\r\n"; +sub __read_multi_bulk { + my ($self,$size) = @_; + return if $size < 0; + my $sock = $self->{sock}; + + $size--; + + my @list = ( 0 .. $size ); + foreach ( 0 .. $size ) { + $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) ); + } + + warn "## list = ", Dumper( @list ) if $self->{debug}; + return @list; } +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, $k, $v, $new ) = @_; - print $sock "SET" . ( $new ? 'NX' : '' ) . " $k " . length($v) . "\r\n$v\r\n"; - _sock_ok(); -} + $r->setnx( foo => 42 ); =head2 get my $value = $r->get( 'foo' ); -=cut +=head2 mget -sub get { - my ( $self, $k ) = @_; - print $sock "GET $k\r\n"; - _sock_result_bulk(); -} + my @values = $r->mget( 'foo', 'bar', 'baz' ); =head2 incr $r->incr('counter'); - $r->incr('tripplets', 3); - -=cut - - -sub incr { - my ( $self, $key, $value ) = @_; - if ( defined $value ) { - print $sock "INCRBY $key $value\r\n"; - } else { - print $sock "INCR $key\r\n"; - } - _sock_result(); -} + $r->incrby('tripplets', 3); =head2 decr $r->decr('counter'); - $r->decr('tripplets', 3); -=cut - -sub decr { - my ( $self, $key, $value ) = @_; - if ( defined $value ) { - print $sock "DECRBY $key $value\r\n"; - } else { - print $sock "DECR $key\r\n"; - } - _sock_result(); -} + $r->decrby('tripplets', 3); =head2 exists $r->exists( 'key' ) && print "got key!"; -=cut - -sub exists { - my ( $self, $key ) = @_; - print $sock "EXISTS $key\r\n"; - _sock_result(); -} - =head2 del $r->del( 'key' ) || warn "key doesn't exist"; -=cut - -sub del { - my ( $self, $key ) = @_; - print $sock "DEL $key\r\n"; - _sock_result(); -} - =head2 type $r->type( 'key' ); # = string -=cut - -sub type { - my ( $self, $key ) = @_; - print $sock "TYPE $key\r\n"; - _sock_result(); -} - =head1 Commands operating on the key space =head2 keys my @keys = $r->keys( '*glob_pattern*' ); -=cut - -sub keys { - my ( $self, $glob ) = @_; - print $sock "KEYS $glob\r\n"; - return split(/\s/, _sock_result_bulk()); -} - =head2 randomkey my $key = $r->randomkey; -=cut - -sub randomkey { - my ( $self ) = @_; - print $sock "RANDOMKEY\r\n"; - _sock_result(); -} - =head2 rename my $ok = $r->rename( 'old-key', 'new-key', $new ); -=cut +=head2 dbsize -sub rename { - my ( $self, $old, $new, $nx ) = @_; - print $sock "RENAME" . ( $nx ? 'NX' : '' ) . " $old $new\r\n"; - _sock_ok(); -} + my $nr_keys = $r->dbsize; + +=head1 Commands operating on lists + +See also L for tie interface. + +=head2 rpush + + $r->rpush( $key, $value ); + +=head2 lpush + + $r->lpush( $key, $value ); + +=head2 llen + + $r->llen( $key ); + +=head2 lrange + + my @list = $r->lrange( $key, $start, $end ); + +=head2 ltrim + + my $ok = $r->ltrim( $key, $start, $end ); + +=head2 lindex + + $r->lindex( $key, $index ); + +=head2 lset + + $r->lset( $key, $index, $value ); + +=head2 lrem + + my $modified_count = $r->lrem( $key, $count, $value ); + +=head2 lpop + + my $value = $r->lpop( $key ); + +=head2 rpop + + my $value = $r->rpop( $key ); + +=head1 Commands operating on sets + +=head2 sadd + + $r->sadd( $key, $member ); + +=head2 srem + + $r->srem( $key, $member ); + +=head2 scard + + my $elements = $r->scard( $key ); + +=head2 sismember + + $r->sismember( $key, $member ); + +=head2 sinter + + $r->sinter( $key1, $key2, ... ); + +=head2 sinterstore + + my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... ); + +=head1 Multiple databases handling commands + +=head2 select + + $r->select( $dbindex ); # 0 for new clients + +=head2 move + + $r->move( $key, $dbindex ); + +=head2 flushdb + + $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 @@ -255,6 +398,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: @@ -285,7 +430,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.