/[Redis.pre-github]/lib/Redis.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /lib/Redis.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 47 by dpavlin, Mon Mar 23 11:30:40 2009 UTC revision 71 by dpavlin, Fri Mar 19 14:38:13 2010 UTC
# Line 4  use warnings; Line 4  use warnings;
4  use strict;  use strict;
5    
6  use IO::Socket::INET;  use IO::Socket::INET;
7  use Data::Dump qw/dump/;  use Data::Dumper;
8  use Carp qw/confess/;  use Carp qw/confess/;
9    use Encode;
10    
11  =head1 NAME  =head1 NAME
12    
# Line 13  Redis - perl binding for Redis database Line 14  Redis - perl binding for Redis database
14    
15  =cut  =cut
16    
17  our $VERSION = '0.01';  our $VERSION = '1.2001';
18    
19    
20  =head1 SYNOPSIS  =head1 DESCRIPTION
21    
22  Pure perl bindings for L<http://code.google.com/p/redis/>  Pure perl bindings for L<http://code.google.com/p/redis/>
23    
24  This version support git version of Redis available at  This version supports protocol 1.2 or later of Redis available at
 L<git://github.com/antirez/redis>  
25    
26      use Redis;  L<git://github.com/antirez/redis>
27    
28      my $r = Redis->new();  This documentation
29    lists commands which are exercised in test suite, but
30    additinal commands will work correctly since protocol
31    specifies enough information to support almost all commands
32    with same peace of code with a little help of C<AUTOLOAD>.
33    
34  =head1 FUNCTIONS  =head1 FUNCTIONS
35    
36  =head2 new  =head2 new
37    
38  =cut    my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
39    
40  our $debug = $ENV{REDIS} || 0;    my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
41    
42  our $sock;  =cut
 my $server = '127.0.0.1:6379';  
43    
44  sub new {  sub new {
45          my $class = shift;          my $class = shift;
46          my $self = {};          my $self = {@_};
47          bless($self, $class);          $self->{debug} ||= $ENV{REDIS_DEBUG};
   
         warn "# opening socket to $server";  
48    
49          $sock ||= IO::Socket::INET->new(          $self->{sock} = IO::Socket::INET->new(
50                  PeerAddr => $server,                  PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
51                  Proto => 'tcp',                  Proto => 'tcp',
52          ) || die $!;          ) || die $!;
53    
54            bless($self, $class);
55          $self;          $self;
56  }  }
57    
58  sub __sock_result {  my $bulk_command = {
59          my $result = <$sock>;          set => 1,       setnx => 1,
60          warn "## result: ",dump( $result ) if $debug;          rpush => 1,     lpush => 1,
61          $result =~ s{\r\n$}{} || warn "can't find cr/lf";          lset => 1,      lrem => 1,
62          return $result;          sadd => 1,      srem => 1,
63            sismember => 1,
64            echo => 1,
65            getset => 1,
66            smove => 1,
67            zadd => 1,
68            zrem => 1,
69            zscore => 1,
70            zincrby => 1,
71            append => 1,
72    };
73    
74    # we don't want DESTROY to fallback into AUTOLOAD
75    sub DESTROY {}
76    
77    our $AUTOLOAD;
78    sub AUTOLOAD {
79            my $self = shift;
80    
81            use bytes;
82    
83            my $sock = $self->{sock} || die "no server connected";
84    
85            my $command = $AUTOLOAD;
86            $command =~ s/.*://;
87    
88            warn "## $command ",Dumper(@_) if $self->{debug};
89    
90            my $send;
91    
92            if ( defined $bulk_command->{$command} ) {
93                    my $value = pop;
94                    $value = '' if ! defined $value;
95                    $send
96                            = uc($command)
97                            . ' '
98                            . join(' ', @_)
99                            . ' '
100                            . length( $value )
101                            . "\r\n$value\r\n"
102                            ;
103            } else {
104                    $send
105                            = uc($command)
106                            . ' '
107                            . join(' ', @_)
108                            . "\r\n"
109                            ;
110            }
111    
112            warn ">> $send" if $self->{debug};
113            print $sock $send;
114    
115            if ( $command eq 'quit' ) {
116                    close( $sock ) || die "can't close socket: $!";
117                    return 1;
118            }
119    
120            my $result = <$sock> || die "can't read socket: $!";
121            Encode::_utf8_on($result);
122            warn "<< $result" if $self->{debug};
123            my $type = substr($result,0,1);
124            $result = substr($result,1,-2);
125    
126            if ( $command eq 'info' ) {
127                    my $hash;
128                    foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
129                            my ($n,$v) = split(/:/, $l, 2);
130                            $hash->{$n} = $v;
131                    }
132                    return $hash;
133            } elsif ( $command eq 'keys' ) {
134                    my $keys = $self->__read_bulk($result);
135                    return split(/\s/, $keys) if $keys;
136                    return;
137            }
138    
139            if ( $type eq '-' ) {
140                    confess "[$command] $result";
141            } elsif ( $type eq '+' ) {
142                    return $result;
143            } elsif ( $type eq '$' ) {
144                    return $self->__read_bulk($result);
145            } elsif ( $type eq '*' ) {
146                    return $self->__read_multi_bulk($result);
147            } elsif ( $type eq ':' ) {
148                    return $result; # FIXME check if int?
149            } else {
150                    confess "unknown type: $type", $self->__read_line();
151            }
152  }  }
153    
154  sub __sock_read_bulk {  sub __read_bulk {
155          my $len = <$sock>;          my ($self,$len) = @_;
156          warn "## bulk len: ",dump($len) if $debug;          return undef if $len < 0;
157          return undef if $len eq "nil\r\n";  
158          my $v;          my $v;
159          if ( $len > 0 ) {          if ( $len > 0 ) {
160                  read($sock, $v, $len) || die $!;                  read($self->{sock}, $v, $len) || die $!;
161                  warn "## bulk v: ",dump($v) if $debug;                  Encode::_utf8_on($v);
162                    warn "<< ",Dumper($v),$/ if $self->{debug};
163          }          }
164          my $crlf;          my $crlf;
165          read($sock, $crlf, 2); # skip cr/lf          read($self->{sock}, $crlf, 2); # skip cr/lf
166          return $v;          return $v;
167  }  }
168    
169  sub _sock_result_bulk {  sub __read_multi_bulk {
170          my $self = shift;          my ($self,$size) = @_;
171          warn "## _sock_result_bulk ",dump( @_ ) if $debug;          return undef if $size < 0;
172          print $sock join(' ',@_) . "\r\n";          my $sock = $self->{sock};
         __sock_read_bulk();  
 }  
   
 sub _sock_result_bulk_list {  
         my $self = shift;  
         warn "## _sock_result_bulk_list ",dump( @_ ) if $debug;  
173    
         my $size = $self->_sock_send( @_ );  
         confess $size unless $size > 0;  
174          $size--;          $size--;
175    
176          my @list = ( 0 .. $size );          my @list = ( 0 .. $size );
177          foreach ( 0 .. $size ) {          foreach ( 0 .. $size ) {
178                  $list[ $_ ] = __sock_read_bulk();                  $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
179          }          }
180    
181          warn "## list = ", dump( @list ) if $debug;          warn "## list = ", Dumper( @list ) if $self->{debug};
182          return @list;          return @list;
183  }  }
184    
185  sub __sock_ok {  1;
         my $ok = <$sock>;  
         return undef if $ok eq "nil\r\n";  
         confess dump($ok) unless $ok eq "+OK\r\n";  
 }  
186    
187  sub _sock_send {  __END__
         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;  
 }  
188    
189  =head1 Connection Handling  =head1 Connection Handling
190    
# Line 145  sub _sock_send_bulk_number { Line 192  sub _sock_send_bulk_number {
192    
193    $r->quit;    $r->quit;
194    
 =cut  
   
 sub quit {  
         my $self = shift;  
   
         close( $sock ) || warn $!;  
 }  
   
195  =head2 ping  =head2 ping
196    
197    $r->ping || die "no server?";    $r->ping || die "no server?";
198    
 =cut  
   
 sub ping {  
         print $sock "PING\r\n";  
         my $pong = <$sock>;  
         die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";  
 }  
   
199  =head1 Commands operating on string values  =head1 Commands operating on string values
200    
201  =head2 set  =head2 set
202    
203    $r->set( foo => 'bar', $new );    $r->set( foo => 'bar' );
   
 =cut  
204    
205  sub set {    $r->setnx( foo => 42 );
         my ( $self, $key, $value, $new ) = @_;  
         $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );  
 }  
206    
207  =head2 get  =head2 get
208    
209    my $value = $r->get( 'foo' );    my $value = $r->get( 'foo' );
210    
 =cut  
   
 sub get {  
         my $self = shift;  
         $self->_sock_result_bulk('GET',@_);  
 }  
   
211  =head2 mget  =head2 mget
212    
213    my @values = $r->get( 'foo', 'bar', 'baz' );    my @values = $r->mget( 'foo', 'bar', 'baz' );
   
 =cut  
   
 sub mget {  
         my $self = shift;  
         $self->_sock_result_bulk_list('MGET',@_);  
 }  
214    
215  =head2 incr  =head2 incr
216    
217    $r->incr('counter');    $r->incr('counter');
   $r->incr('tripplets', 3);  
   
 =cut  
218    
219              $r->incrby('tripplets', 3);
   
 sub incr {  
         my $self = shift;  
         $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );  
 }  
220    
221  =head2 decr  =head2 decr
222    
223    $r->decr('counter');    $r->decr('counter');
   $r->decr('tripplets', 3);  
   
 =cut  
224    
225  sub decr {    $r->decrby('tripplets', 3);
         my $self = shift;  
         $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );  
 }  
226    
227  =head2 exists  =head2 exists
228    
229    $r->exists( 'key' ) && print "got key!";    $r->exists( 'key' ) && print "got key!";
230    
 =cut  
   
 sub exists {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'EXISTS', $key );  
 }  
   
231  =head2 del  =head2 del
232    
233    $r->del( 'key' ) || warn "key doesn't exist";    $r->del( 'key' ) || warn "key doesn't exist";
234    
 =cut  
   
 sub del {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'DEL', $key );  
 }  
   
235  =head2 type  =head2 type
236    
237    $r->type( 'key' ); # = string    $r->type( 'key' ); # = string
238    
 =cut  
   
 sub type {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'TYPE', $key );  
 }  
   
239  =head1 Commands operating on the key space  =head1 Commands operating on the key space
240    
241  =head2 keys  =head2 keys
242    
243    my @keys = $r->keys( '*glob_pattern*' );    my @keys = $r->keys( '*glob_pattern*' );
244    
 =cut  
   
 sub keys {  
         my ( $self, $glob ) = @_;  
         my $keys = $self->_sock_result_bulk( 'KEYS', $glob );  
         return split(/\s/, $keys) if $keys;  
         return () if wantarray;  
 }  
   
245  =head2 randomkey  =head2 randomkey
246    
247    my $key = $r->randomkey;    my $key = $r->randomkey;
248    
 =cut  
   
 sub randomkey {  
         my ( $self ) = @_;  
         $self->_sock_send( 'RANDOMKEY' );  
 }  
   
249  =head2 rename  =head2 rename
250    
251    my $ok = $r->rename( 'old-key', 'new-key', $new );    my $ok = $r->rename( 'old-key', 'new-key', $new );
252    
 =cut  
   
 sub rename {  
         my ( $self, $old, $new, $nx ) = @_;  
         $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );  
 }  
   
253  =head2 dbsize  =head2 dbsize
254    
255    my $nr_keys = $r->dbsize;    my $nr_keys = $r->dbsize;
256    
 =cut  
   
 sub dbsize {  
         my ( $self ) = @_;  
         $self->_sock_send('DBSIZE');  
 }  
   
257  =head1 Commands operating on lists  =head1 Commands operating on lists
258    
259  See also L<Redis::List> for tie interface.  See also L<Redis::List> for tie interface.
# Line 315  See also L<Redis::List> for tie interfac Line 262  See also L<Redis::List> for tie interfac
262    
263    $r->rpush( $key, $value );    $r->rpush( $key, $value );
264    
 =cut  
   
 sub rpush {  
         my ( $self, $key, $value ) = @_;  
         $self->_sock_send_bulk('RPUSH', $key, $value);  
 }  
   
265  =head2 lpush  =head2 lpush
266    
267    $r->lpush( $key, $value );    $r->lpush( $key, $value );
268    
 =cut  
   
 sub lpush {  
         my ( $self, $key, $value ) = @_;  
         $self->_sock_send_bulk('LPUSH', $key, $value);  
 }  
   
269  =head2 llen  =head2 llen
270    
271    $r->llen( $key );    $r->llen( $key );
272    
 =cut  
   
 sub llen {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'LLEN', $key );  
 }  
   
273  =head2 lrange  =head2 lrange
274    
275    my @list = $r->lrange( $key, $start, $end );    my @list = $r->lrange( $key, $start, $end );
276    
 =cut  
   
 sub lrange {  
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_result_bulk_list('LRANGE', $key, $start, $end);  
 }  
   
277  =head2 ltrim  =head2 ltrim
278    
279    my $ok = $r->ltrim( $key, $start, $end );    my $ok = $r->ltrim( $key, $start, $end );
280    
 =cut  
   
 sub ltrim {  
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_send_ok( 'LTRIM', $key, $start, $end );  
 }  
   
281  =head2 lindex  =head2 lindex
282    
283    $r->lindex( $key, $index );    $r->lindex( $key, $index );
284    
 =cut  
   
 sub lindex {  
         my ( $self, $key, $index ) = @_;  
         $self->_sock_result_bulk( 'LINDEX', $key, $index );  
 }  
   
285  =head2 lset  =head2 lset
286    
287    $r->lset( $key, $index, $value );    $r->lset( $key, $index, $value );
288    
 =cut  
   
 sub lset {  
         my ( $self, $key, $index, $value ) = @_;  
         $self->_sock_send_bulk( 'LSET', $key, $index, $value );  
 }  
   
289  =head2 lrem  =head2 lrem
290    
291    my $modified_count = $r->lrem( $key, $count, $value );    my $modified_count = $r->lrem( $key, $count, $value );
292    
 =cut  
   
 sub lrem {  
         my ( $self, $key, $count, $value ) = @_;  
         $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );  
 }  
   
293  =head2 lpop  =head2 lpop
294    
295    my $value = $r->lpop( $key );    my $value = $r->lpop( $key );
296    
 =cut  
   
 sub lpop {  
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'LPOP', $key );  
 }  
   
297  =head2 rpop  =head2 rpop
298    
299    my $value = $r->rpop( $key );    my $value = $r->rpop( $key );
300    
 =cut  
   
 sub rpop {  
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'RPOP', $key );  
 }  
   
301  =head1 Commands operating on sets  =head1 Commands operating on sets
302    
303  =head2 sadd  =head2 sadd
304    
305    $r->sadd( $key, $member );    $r->sadd( $key, $member );
306    
 =cut  
   
 sub sadd {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SADD', $key, $member );  
 }  
   
307  =head2 srem  =head2 srem
308    
309    $r->srem( $key, $member );    $r->srem( $key, $member );
310    
 =cut  
   
 sub srem {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SREM', $key, $member );  
 }  
   
311  =head2 scard  =head2 scard
312    
313    my $elements = $r->scard( $key );    my $elements = $r->scard( $key );
314    
 =cut  
   
 sub scard {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'SCARD', $key );  
 }  
   
315  =head2 sismember  =head2 sismember
316    
317    $r->sismember( $key, $member );    $r->sismember( $key, $member );
318    
 =cut  
   
 sub sismember {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member );  
 }  
   
319  =head2 sinter  =head2 sinter
320    
321    $r->sinter( $key1, $key2, ... );    $r->sinter( $key1, $key2, ... );
322    
 =cut  
   
 sub sinter {  
         my $self = shift;  
         $self->_sock_result_bulk_list( 'SINTER', @_ );  
 }  
   
323  =head2 sinterstore  =head2 sinterstore
324    
325    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
326    
 =cut  
   
 sub sinterstore {  
         my $self = shift;  
         $self->_sock_send_ok( 'SINTERSTORE', @_ );  
 }  
   
327  =head1 Multiple databases handling commands  =head1 Multiple databases handling commands
328    
329  =head2 select  =head2 select
330    
331    $r->select( $dbindex ); # 0 for new clients    $r->select( $dbindex ); # 0 for new clients
332    
 =cut  
   
 sub select {  
         my ($self,$dbindex) = @_;  
         confess dump($dbindex) . 'not number' unless $dbindex =~ m{^\d+$};  
         $self->_sock_send_ok( 'SELECT', $dbindex );  
 }  
   
333  =head2 move  =head2 move
334    
335    $r->move( $key, $dbindex );    $r->move( $key, $dbindex );
336    
 =cut  
   
 sub move {  
         my ( $self, $key, $dbindex ) = @_;  
         $self->_sock_send( 'MOVE', $key, $dbindex );  
 }  
   
337  =head2 flushdb  =head2 flushdb
338    
339    $r->flushdb;    $r->flushdb;
340    
 =cut  
   
 sub flushdb {  
         my $self = shift;  
         $self->_sock_send_ok('FLUSHDB');  
 }  
   
341  =head2 flushall  =head2 flushall
342    
343    $r->flushall;    $r->flushall;
344    
 =cut  
   
 sub flushall {  
         my $self = shift;  
         $self->_sock_send_ok('flushall');  
 }  
   
345  =head1 Sorting  =head1 Sorting
346    
347    =head2 sort
348    
349    $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');    $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
350    
351  =cut  =head1 Persistence control commands
352    
353  sub sort {  =head2 save
354          my ( $self, $sort ) = @_;  
355          $self->_sock_result_bulk_list( "SORT $sort" );    $r->save;
356  }  
357    =head2 bgsave
358    
359      $r->bgsave;
360    
361    =head2 lastsave
362    
363      $r->lastsave;
364    
365    =head2 shutdown
366    
367      $r->shutdown;
368    
369    =head1 Remote server control commands
370    
371    =head2 info
372    
373      my $info_hash = $r->info;
374    
375    =head1 ENCODING
376    
377    Since Redis knows nothing about encoding, we are forcing utf-8 flag on all data received from Redis.
378    This change is introduced in 1.2001 version.
379    
380    This allows us to round-trip utf-8 encoded characters correctly, but might be problem if you push
381    binary junk into Redis and expect to get it back without utf-8 flag turned on.
382    
383  =head1 AUTHOR  =head1 AUTHOR
384    
# Line 565  automatically be notified of progress on Line 398  automatically be notified of progress on
398  You can find documentation for this module with the perldoc command.  You can find documentation for this module with the perldoc command.
399    
400      perldoc Redis      perldoc Redis
401            perldoc Redis::List
402            perldoc Redis::Hash
403    
404    
405  You can also look for information at:  You can also look for information at:
# Line 595  L<http://search.cpan.org/dist/Redis> Line 430  L<http://search.cpan.org/dist/Redis>
430    
431  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
432    
433  Copyright 2009 Dobrica Pavlinusic, all rights reserved.  Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
434    
435  This program is free software; you can redistribute it and/or modify it  This program is free software; you can redistribute it and/or modify it
436  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.47  
changed lines
  Added in v.71
  ViewVC Help
Powered by ViewVC 1.1.26