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