/[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 32 by dpavlin, Sun Mar 22 17:06:34 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    
13  Redis - The great new Redis!  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      use Redis;  This version supports protocol 1.2 or later of Redis available at
   
     my $r = Redis->new();  
   
25    
26    L<git://github.com/antirez/redis>
27    
28    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 $sock;    my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
41  my $server = '127.0.0.1:6379';  
42    =cut
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};
48    
49          warn "# opening socket to $server";          $self->{sock} = IO::Socket::INET->new(
50                    PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
         $sock ||= IO::Socket::INET->new(  
                 PeerAddr => $server,  
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 );          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);          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);                  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( @_ );          return undef if $size < 0;
172          print $sock join(' ',@_) . "\r\n";          my $sock = $self->{sock};
         _sock_read_bulk();  
 }  
   
 sub __sock_ok {  
         my $ok = <$sock>;  
         return undef if $ok eq "nil\r\n";  
         confess dump($ok) unless $ok eq "+OK\r\n";  
 }  
173    
174  sub _sock_send {          $size--;
         my $self = shift;  
         warn "## _sock_send ",dump( @_ );  
         print $sock join(' ',@_) . "\r\n";  
         _sock_result();  
 }  
175    
176  sub _sock_send_ok {          my @list = ( 0 .. $size );
177          my $self = shift;          foreach ( 0 .. $size ) {
178          warn "## _sock_send_ok ",dump( @_ );                  $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
179          print $sock join(' ',@_) . "\r\n";          }
         __sock_ok();  
 }  
180    
181  sub __sock_send_bulk_raw {          warn "## list = ", Dumper( @list ) if $self->{debug};
182          my $self = shift;          return @list;
         warn "## _sock_send_bulk ",dump( @_ );  
         my $value = pop;  
         $value = '' unless defined $value; # FIXME errr? nil?  
         print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n"  
183  }  }
184    
185  sub _sock_send_bulk {  1;
         __sock_send_bulk_raw( @_ );  
         __sock_ok();  
 }  
186    
187  sub _sock_send_bulk_number {  __END__
         __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 125  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' );
204    
205  =cut    $r->setnx( foo => 42 );
   
 sub set {  
         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    
211  =cut  =head2 mget
212    
213  sub get {    my @values = $r->mget( 'foo', 'bar', 'baz' );
         my $self = shift;  
         $self->_sock_result_bulk('GET', @_);  
 }  
214    
215  =head2 incr  =head2 incr
216    
217    $r->incr('counter');    $r->incr('counter');
   $r->incr('tripplets', 3);  
218    
219  =cut    $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);  
224    
225  =cut    $r->decrby('tripplets', 3);
   
 sub decr {  
         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 ) = @_;  
         return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));  
 }  
   
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.
260    
261  =head2 rpush  =head2 rpush
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    
277  =cut  =head2 ltrim
278    
279  sub lrange {    my $ok = $r->ltrim( $key, $start, $end );
         my ( $self, $key, $start, $end ) = @_;  
         my $size = $self->_sock_send('LRANGE', $key, $start, $end);  
280    
281          confess $size unless $size > 0;  =head2 lindex
         $size--;  
282    
283          my @list = ( 0 .. $size );    $r->lindex( $key, $index );
         foreach ( 0 .. $size ) {  
                 $list[ $_ ] = _sock_read_bulk();  
         }  
284    
285          warn "## lrange $key $start $end = [$size] ", dump( @list );  =head2 lset
         return @list;  
 }  
286    
287  =head2 ltrim    $r->lset( $key, $index, $value );
288    
289    my $ok = $r->ltrim( $key, $start, $end );  =head2 lrem
290    
291  =cut    my $modified_count = $r->lrem( $key, $count, $value );
292    
293  sub ltrim {  =head2 lpop
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_send_ok( 'LTRIM', $key, $start, $end );  
 }  
294    
295  =head2 lindex    my $value = $r->lpop( $key );
296    
297    $r->lindex( $key, $index );  =head2 rpop
298    
299  =cut    my $value = $r->rpop( $key );
300    
301  sub lindex {  =head1 Commands operating on sets
         my ( $self, $key, $index ) = @_;  
         $self->_sock_result_bulk( 'LINDEX', $key, $index );  
 }  
302    
303  =head2 lset  =head2 sadd
304    
305    $r->lset( $key, $index, $value );    $r->sadd( $key, $member );
306    
307  =cut  =head2 srem
308    
309  sub lset {    $r->srem( $key, $member );
         my ( $self, $key, $index, $value ) = @_;  
         $self->_sock_send_bulk( 'LSET', $key, $index, $value );  
 }  
310    
311  =head2 lrem  =head2 scard
312    
313    my $modified_count = $r->lrem( $key, $count, $value );    my $elements = $r->scard( $key );
314    
315  =cut  =head2 sismember
316    
317  sub lrem {    $r->sismember( $key, $member );
         my ( $self, $key, $count, $value ) = @_;  
         $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );  
 }  
318    
319  =head2 lpop  =head2 sinter
320    
321    my $value = $r->lpop( $key );    $r->sinter( $key1, $key2, ... );
322    
323  =cut  =head2 sinterstore
324    
325  sub lpop {    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'LPOP', $key );  
 }  
326    
327  =head2 rpop  =head1 Multiple databases handling commands
328    
329    my $value = $r->rpop( $key );  =head2 select
330    
331  =cut    $r->select( $dbindex ); # 0 for new clients
332    
333  sub rpop {  =head2 move
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'RPOP', $key );  
 }  
334    
335  =head1 Commands operating on sets    $r->move( $key, $dbindex );
336    
337  =head2 sadd  =head2 flushdb
338    
339    $r->sadd( $key, $member );    $r->flushdb;
340    
341  =cut  =head2 flushall
342    
343  sub sadd {    $r->flushall;
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SADD', $key, $member );  
 }  
344    
345  =head2 srem  =head1 Sorting
346    
347    $r->srem( $key, $member );  =head2 sort
348    
349  =cut    $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
350    
351  sub srem {  =head1 Persistence control commands
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SREM', $key, $member );  
 }  
352    
353  =head2 scard  =head2 save
354    
355    my $elements = $r->scard( $key );    $r->save;
356    
357  =cut  =head2 bgsave
358    
359  sub scard {    $r->bgsave;
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'SCARD', $key );  
 }  
360    
361  =head2 sismember  =head2 lastsave
362    
363    $r->sismember( $key, $member );    $r->lastsave;
364    
365  =cut  =head2 shutdown
366    
367  sub sismember {    $r->shutdown;
368          my ( $self, $key, $member ) = @_;  
369          $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member );  =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 461  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 491  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.32  
changed lines
  Added in v.71
  ViewVC Help
Powered by ViewVC 1.1.26