X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=lib%2FRedis.pm;h=ca065b99fc6708cedaba8695a0ee99095e87a8c7;hb=529539c1e3bc1aa0a19bb9bde72a2352be7f76ff;hp=cb78dc96b9ae8dd8201056be9ecaa3e3a8acb1a7;hpb=158e8571dfb13b4cf308b1b00866c6557593336d;p=perl-Redis.git diff --git a/lib/Redis.pm b/lib/Redis.pm index cb78dc9..ca065b9 100644 --- a/lib/Redis.pm +++ b/lib/Redis.pm @@ -4,105 +4,196 @@ 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); + 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, + $self->{server} ||= $ENV{REDIS_SERVER} || '127.0.0.1:6379'; + $self->{sock} = IO::Socket::INET->new( + PeerAddr => $self->{server}, Proto => 'tcp', - ) || die $!; + ) || confess("Could not connect to Redis server at $self->{server}: $!"); - $self; + return bless($self, $class); } -sub _sock_result { - my $result = <$sock>; - warn "# result: ",dump( $result ); - $result =~ s{\r\n$}{} || warn "can't find cr/lf"; - return $result; -} +# we don't want DESTROY to fallback into AUTOLOAD +sub DESTROY {} -sub _sock_read_bulk { - my $len = <$sock>; - warn "## bulk len: ",dump($len); - return undef if $len eq "nil\r\n"; - my $v; - read($sock, $v, $len) || die $!; - warn "## bulk v: ",dump($v); - my $crlf; - read($sock, $crlf, 2); # skip cr/lf - return $v; -} -sub _sock_result_bulk { +### Deal with common, general case, Redis commands +our $AUTOLOAD; +sub AUTOLOAD { my $self = shift; - warn "## _sock_result_bulk ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - _sock_read_bulk(); + my $sock = $self->{sock} || confess("Not connected to any server"); + my $enc = $self->{encoding}; + my $deb = $self->{debug}; + + my $command = $AUTOLOAD; + $command =~ s/.*://; + + $self->__send_command($command, @_); + + my $result = <$sock> || confess("Can't read socket: $!"); + my $type = substr($result,0,1); + $result = substr($result,1,-2); + + $result = decode($enc, $result) if $enc; + warn "[RECV] '$type$result'" if $deb; + + 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' ) { + return $self->__read_multi_bulk($result) + if $type eq '*'; + 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_ok { - my $ok = <$sock>; - confess dump($ok) unless $ok eq "+OK\r\n"; + +### Commands with extra logic + +sub quit { + my ($self) = @_; + + $self->__send_command('QUIT'); + + close(delete $self->{sock}) || confess("Can't close socket: $!"); + return 1; } -sub _sock_send { - my $self = shift; - warn "## _sock_send ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - _sock_result(); + +### 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 _sock_send_ok { - my $self = shift; - warn "## _sock_send_ok ",dump( @_ ); - print $sock join(' ',@_) . "\r\n"; - _sock_ok(); +sub __read_bulk { + my ($self,$len) = @_; + return if $len < 0; + + my $enc = $self->{encoding}; + my $v = ''; + if ( $len > 0 ) { + read($self->{sock}, $v, $len) || confess("Could not read from sock: $!"); + $v = decode($enc, $v) if $enc; + } + my $crlf; + read($self->{sock}, $crlf, 2); # skip cr/lf + + warn "[PARSE] read_bulk ".Dumper($v) if $self->{debug}; + return $v; } -sub _sock_send_bulk { - my $self = shift; - my $value = pop; - print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n"; - _sock_ok(); +sub __read_multi_bulk { + my ($self,$size) = @_; + return if $size <= 0; + + my $sock = $self->{sock}; + my $deb = $self->{debug}; + my $enc = $self->{encoding}; + my @list; + while ($size--) { + my $v = $self->__read_bulk( substr(<$sock>,1,-2) ); + $v = decode($enc, $v) if $enc; + warn " [PARSE] read_multi_bulk ($size) ".Dumper($v) if $deb; + push @list, $v; + } + + warn "[PARSE] multi_bulk ".Dumper( \@list ) if $deb; + return @list; } +1; + +__END__ =head1 Connection Handling @@ -110,244 +201,193 @@ sub _sock_send_bulk { $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 +=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 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 @@ -367,6 +407,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: @@ -397,7 +439,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.