/[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 19 by dpavlin, Sun Mar 22 09:46:14 2009 UTC revision 41 by dpavlin, Sun Mar 22 18:42:21 2009 UTC
# Line 9  use Carp qw/confess/; Line 9  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    
# Line 20  our $VERSION = '0.01'; Line 20  our $VERSION = '0.01';
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    This version support git version of Redis available at
24    L<git://github.com/antirez/redis>
25    
26      use Redis;      use Redis;
27    
28      my $r = Redis->new();      my $r = Redis->new();
29    
   
   
   
30  =head1 FUNCTIONS  =head1 FUNCTIONS
31    
32  =head2 new  =head2 new
33    
34  =cut  =cut
35    
36    our $debug = $ENV{REDIS} || 0;
37    
38  our $sock;  our $sock;
39  my $server = '127.0.0.1:6379';  my $server = '127.0.0.1:6379';
40    
# Line 51  sub new { Line 53  sub new {
53          $self;          $self;
54  }  }
55    
56  sub _sock_result {  sub __sock_result {
57          my $result = <$sock>;          my $result = <$sock>;
58          warn "# result: ",dump( $result );          warn "## result: ",dump( $result ) if $debug;
59          $result =~ s{\r\n$}{} || warn "can't find cr/lf";          $result =~ s{\r\n$}{} || warn "can't find cr/lf";
60          return $result;          return $result;
61  }  }
62    
63  sub _sock_result_bulk {  sub __sock_read_bulk {
64          my $len = <$sock>;          my $len = <$sock>;
65          warn "# len: ",dump($len);          warn "## bulk len: ",dump($len) if $debug;
66          return undef if $len eq "nil\r\n";          return undef if $len eq "nil\r\n";
67          my $v;          my $v;
68          read($sock, $v, $len) || die $!;          if ( $len > 0 ) {
69          warn "# v: ",dump($v);                  read($sock, $v, $len) || die $!;
70                    warn "## bulk v: ",dump($v) if $debug;
71            }
72          my $crlf;          my $crlf;
73          read($sock, $crlf, 2); # skip cr/lf          read($sock, $crlf, 2); # skip cr/lf
74          return $v;          return $v;
75  }  }
76    
77  sub _sock_ok {  sub _sock_result_bulk {
78            my $self = shift;
79            warn "## _sock_result_bulk ",dump( @_ ) if $debug;
80            print $sock join(' ',@_) . "\r\n";
81            __sock_read_bulk();
82    }
83    
84    sub _sock_result_bulk_list {
85            my $self = shift;
86            warn "## _sock_result_bulk_list ",dump( @_ ) if $debug;
87    
88            my $size = $self->_sock_send( @_ );
89            confess $size unless $size > 0;
90            $size--;
91    
92            my @list = ( 0 .. $size );
93            foreach ( 0 .. $size ) {
94                    $list[ $_ ] = __sock_read_bulk();
95            }
96    
97            warn "## list = ", dump( @list ) if $debug;
98            return @list;
99    }
100    
101    sub __sock_ok {
102          my $ok = <$sock>;          my $ok = <$sock>;
103            return undef if $ok eq "nil\r\n";
104          confess dump($ok) unless $ok eq "+OK\r\n";          confess dump($ok) unless $ok eq "+OK\r\n";
105  }  }
106    
107    sub _sock_send {
108            my $self = shift;
109            warn "## _sock_send ",dump( @_ ) if $debug;
110            print $sock join(' ',@_) . "\r\n";
111            __sock_result();
112    }
113    
114    sub _sock_send_ok {
115            my $self = shift;
116            warn "## _sock_send_ok ",dump( @_ ) if $debug;
117            print $sock join(' ',@_) . "\r\n";
118            __sock_ok();
119    }
120    
121    sub __sock_send_bulk_raw {
122            warn "## _sock_send_bulk ",dump( @_ ) if $debug;
123            my $value = pop;
124            $value = '' unless defined $value; # FIXME errr? nil?
125            print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n"
126    }
127    
128  sub _sock_send_bulk {  sub _sock_send_bulk {
129          my ( $self, $command, $key, $value ) = @_;          my $self = shift;
130          print $sock "$command $key " . length($value) . "\r\n$value\r\n";          __sock_send_bulk_raw( @_ );
131          _sock_ok();          __sock_ok();
132  }  }
133    
134    sub _sock_send_bulk_number {
135            my $self = shift;
136            __sock_send_bulk_raw( @_ );
137            my $v = __sock_result();
138            confess $v unless $v =~ m{^\-?\d+$};
139            return $v;
140    }
141    
142  =head1 Connection Handling  =head1 Connection Handling
143    
# Line 128  sub set { Line 185  sub set {
185  =cut  =cut
186    
187  sub get {  sub get {
188          my ( $self, $k ) = @_;          my $self = shift;
189          print $sock "GET $k\r\n";          $self->_sock_result_bulk('GET', @_);
         _sock_result_bulk();  
190  }  }
191    
192  =head2 incr  =head2 incr
# Line 143  sub get { Line 199  sub get {
199                    
200    
201  sub incr {  sub incr {
202          my ( $self, $key, $value ) = @_;          my $self = shift;
203          if ( defined $value ) {          $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
                 print $sock "INCRBY $key $value\r\n";  
         } else {  
                 print $sock "INCR $key\r\n";  
         }  
         _sock_result();  
204  }  }
205    
206  =head2 decr  =head2 decr
# Line 160  sub incr { Line 211  sub incr {
211  =cut  =cut
212    
213  sub decr {  sub decr {
214          my ( $self, $key, $value ) = @_;          my $self = shift;
215          if ( defined $value ) {          $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
                 print $sock "DECRBY $key $value\r\n";  
         } else {  
                 print $sock "DECR $key\r\n";  
         }  
         _sock_result();  
216  }  }
217    
218  =head2 exists  =head2 exists
# Line 177  sub decr { Line 223  sub decr {
223    
224  sub exists {  sub exists {
225          my ( $self, $key ) = @_;          my ( $self, $key ) = @_;
226          print $sock "EXISTS $key\r\n";          $self->_sock_send( 'EXISTS', $key );
         _sock_result();  
227  }  }
228    
229  =head2 del  =head2 del
# Line 189  sub exists { Line 234  sub exists {
234    
235  sub del {  sub del {
236          my ( $self, $key ) = @_;          my ( $self, $key ) = @_;
237          print $sock "DEL $key\r\n";          $self->_sock_send( 'DEL', $key );
         _sock_result();  
238  }  }
239    
240  =head2 type  =head2 type
# Line 201  sub del { Line 245  sub del {
245    
246  sub type {  sub type {
247          my ( $self, $key ) = @_;          my ( $self, $key ) = @_;
248          print $sock "TYPE $key\r\n";          $self->_sock_send( 'TYPE', $key );
         _sock_result();  
249  }  }
250    
251  =head1 Commands operating on the key space  =head1 Commands operating on the key space
# Line 215  sub type { Line 258  sub type {
258    
259  sub keys {  sub keys {
260          my ( $self, $glob ) = @_;          my ( $self, $glob ) = @_;
261          print $sock "KEYS $glob\r\n";          return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
         return split(/\s/, _sock_result_bulk());  
262  }  }
263    
264  =head2 randomkey  =head2 randomkey
# Line 227  sub keys { Line 269  sub keys {
269    
270  sub randomkey {  sub randomkey {
271          my ( $self ) = @_;          my ( $self ) = @_;
272          print $sock "RANDOMKEY\r\n";          $self->_sock_send( 'RANDOMKEY' );
         _sock_result();  
273  }  }
274    
275  =head2 rename  =head2 rename
# Line 239  sub randomkey { Line 280  sub randomkey {
280    
281  sub rename {  sub rename {
282          my ( $self, $old, $new, $nx ) = @_;          my ( $self, $old, $new, $nx ) = @_;
283          print $sock "RENAME" . ( $nx ? 'NX' : '' ) . " $old $new\r\n";          $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
         _sock_ok();  
284  }  }
285    
286  =head2 dbsize  =head2 dbsize
# Line 251  sub rename { Line 291  sub rename {
291    
292  sub dbsize {  sub dbsize {
293          my ( $self ) = @_;          my ( $self ) = @_;
294          print $sock "DBSIZE\r\n";          $self->_sock_send('DBSIZE');
         _sock_result();  
295  }  }
296    
297  =head1 Commands operating on lists  =head1 Commands operating on lists
298    
299    See also L<Redis::List> for tie interface.
300    
301  =head2 rpush  =head2 rpush
302    
303    $r->rpush( $key, $value );    $r->rpush( $key, $value );
# Line 279  sub lpush { Line 320  sub lpush {
320          $self->_sock_send_bulk('LPUSH', $key, $value);          $self->_sock_send_bulk('LPUSH', $key, $value);
321  }  }
322    
323    =head2 llen
324    
325      $r->llen( $key );
326    
327    =cut
328    
329    sub llen {
330            my ( $self, $key ) = @_;
331            $self->_sock_send( 'LLEN', $key );
332    }
333    
334    =head2 lrange
335    
336      my @list = $r->lrange( $key, $start, $end );
337    
338    =cut
339    
340    sub lrange {
341            my ( $self, $key, $start, $end ) = @_;
342            $self->_sock_result_bulk_list('LRANGE', $key, $start, $end);
343    }
344    
345    =head2 ltrim
346    
347      my $ok = $r->ltrim( $key, $start, $end );
348    
349    =cut
350    
351    sub ltrim {
352            my ( $self, $key, $start, $end ) = @_;
353            $self->_sock_send_ok( 'LTRIM', $key, $start, $end );
354    }
355    
356    =head2 lindex
357    
358      $r->lindex( $key, $index );
359    
360    =cut
361    
362    sub lindex {
363            my ( $self, $key, $index ) = @_;
364            $self->_sock_result_bulk( 'LINDEX', $key, $index );
365    }
366    
367    =head2 lset
368    
369      $r->lset( $key, $index, $value );
370    
371    =cut
372    
373    sub lset {
374            my ( $self, $key, $index, $value ) = @_;
375            $self->_sock_send_bulk( 'LSET', $key, $index, $value );
376    }
377    
378    =head2 lrem
379    
380      my $modified_count = $r->lrem( $key, $count, $value );
381    
382    =cut
383    
384    sub lrem {
385            my ( $self, $key, $count, $value ) = @_;
386            $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );
387    }
388    
389    =head2 lpop
390    
391      my $value = $r->lpop( $key );
392    
393    =cut
394    
395    sub lpop {
396            my ( $self, $key ) = @_;
397            $self->_sock_result_bulk( 'LPOP', $key );
398    }
399    
400    =head2 rpop
401    
402      my $value = $r->rpop( $key );
403    
404    =cut
405    
406    sub rpop {
407            my ( $self, $key ) = @_;
408            $self->_sock_result_bulk( 'RPOP', $key );
409    }
410    
411    =head1 Commands operating on sets
412    
413    =head2 sadd
414    
415      $r->sadd( $key, $member );
416    
417    =cut
418    
419    sub sadd {
420            my ( $self, $key, $member ) = @_;
421            $self->_sock_send_bulk_number( 'SADD', $key, $member );
422    }
423    
424    =head2 srem
425    
426      $r->srem( $key, $member );
427    
428    =cut
429    
430    sub srem {
431            my ( $self, $key, $member ) = @_;
432            $self->_sock_send_bulk_number( 'SREM', $key, $member );
433    }
434    
435    =head2 scard
436    
437      my $elements = $r->scard( $key );
438    
439    =cut
440    
441    sub scard {
442            my ( $self, $key ) = @_;
443            $self->_sock_send( 'SCARD', $key );
444    }
445    
446    =head2 sismember
447    
448      $r->sismember( $key, $member );
449    
450    =cut
451    
452    sub sismember {
453            my ( $self, $key, $member ) = @_;
454            $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member );
455    }
456    
457    =head2 sinter
458    
459      $r->sinter( $key1, $key2, ... );
460    
461    =cut
462    
463    sub sinter {
464            my $self = shift;
465            $self->_sock_result_bulk_list( 'SINTER', @_ );
466    }
467    
468    =head2 sinterstore
469    
470      my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
471    
472    =cut
473    
474    sub sinterstore {
475            my $self = shift;
476            $self->_sock_send_ok( 'SINTERSTORE', @_ );
477    }
478    
479    =head1 Multiple databases handling commands
480    
481    =head2 select
482    
483      $r->select( $dbindex ); # 0 for new clients
484    
485    =cut
486    
487    sub select {
488            my ($self,$dbindex) = @_;
489            confess dump($dbindex) . 'not number' unless $dbindex =~ m{^\d+$};
490            $self->_sock_send_ok( 'SELECT', $dbindex );
491    }
492    
493    =head2 move
494    
495      $r->move( $key, $dbindex );
496    
497    =cut
498    
499    sub move {
500            my ( $self, $key, $dbindex ) = @_;
501            $self->_sock_send( 'MOVE', $key, $dbindex );
502    }
503    
504    =head2 flushdb
505    
506      $r->flushdb;
507    
508    =cut
509    
510    sub flushdb {
511            my $self = shift;
512            $self->_sock_send_ok('FLUSHDB');
513    }
514    
515    =head2 flushall
516    
517      $r->flushall;
518    
519    =cut
520    
521    sub flushall {
522            my $self = shift;
523            $self->_sock_send_ok('flushall');
524    }
525    
526  =head1 AUTHOR  =head1 AUTHOR
527    
528  Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
Legend:
Removed from v.19  
changed lines
  Added in v.41
  ViewVC Help
Powered by ViewVC 1.1.26