/[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 9 by dpavlin, Sat Mar 21 22:54:10 2009 UTC revision 43 by dpavlin, Sun Mar 22 20:04:17 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 {
57            my $result = <$sock>;
58            warn "## result: ",dump( $result ) if $debug;
59            $result =~ s{\r\n$}{} || warn "can't find cr/lf";
60            return $result;
61    }
62    
63    sub __sock_read_bulk {
64            my $len = <$sock>;
65            warn "## bulk len: ",dump($len) if $debug;
66            return undef if $len eq "nil\r\n";
67            my $v;
68            if ( $len > 0 ) {
69                    read($sock, $v, $len) || die $!;
70                    warn "## bulk v: ",dump($v) if $debug;
71            }
72            my $crlf;
73            read($sock, $crlf, 2); # skip cr/lf
74            return $v;
75    }
76    
77    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>;
103            return undef if $ok eq "nil\r\n";
104            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 {
129            my $self = shift;
130            __sock_send_bulk_raw( @_ );
131            __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    
144  =head2 quit  =head2 quit
# Line 86  sub ping { Line 174  sub ping {
174  =cut  =cut
175    
176  sub set {  sub set {
177          my ( $self, $k, $v, $new ) = @_;          my ( $self, $key, $value, $new ) = @_;
178          print $sock ( $new ? "SETNX" : "SET" ) . " $k " . length($v) . "\r\n$v\r\n";          $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
         my $ok = <$sock>;  
         confess dump($ok) unless $ok eq "+OK\r\n";  
179  }  }
180    
181  =head2 get  =head2 get
# Line 99  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', @_);
         my $len = <$sock>;  
 #       warn "# len: ",dump($len);  
         return undef if $len eq "nil\r\n";  
         my $v;  
         read($sock, $v, $len) || die $!;  
 #       warn "# v: ",dump($v);  
         my $crlf;  
         read($sock, $crlf, 2); # skip cr/lf  
         return $v;  
190  }  }
191    
192  =head2 incr  =head2 incr
# Line 119  sub get { Line 196  sub get {
196    
197  =cut  =cut
198    
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";  
         }  
         my $count = <$sock>;  
         warn "# $key = $count";  
         return $count;  
204  }  }
205    
206  =head2 decr  =head2 decr
# Line 139  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";  
         }  
         my $count = <$sock>;  
         warn "# $key = $count";  
         return $count;  
216  }  }
217    
218  =head2 exists  =head2 exists
# Line 158  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 );
227          my $found = <$sock>;  }
228          $found =~ s{\r\n$}{};  
229          warn "# exists $key = $found";  =head2 del
230          return $found;  
231      $r->del( 'key' ) || warn "key doesn't exist";
232    
233    =cut
234    
235    sub del {
236            my ( $self, $key ) = @_;
237            $self->_sock_send( 'DEL', $key );
238    }
239    
240    =head2 type
241    
242      $r->type( 'key' ); # = string
243    
244    =cut
245    
246    sub type {
247            my ( $self, $key ) = @_;
248            $self->_sock_send( 'TYPE', $key );
249    }
250    
251    =head1 Commands operating on the key space
252    
253    =head2 keys
254    
255      my @keys = $r->keys( '*glob_pattern*' );
256    
257    =cut
258    
259    sub keys {
260            my ( $self, $glob ) = @_;
261            my $keys = $self->_sock_result_bulk( 'KEYS', $glob );
262            return split(/\s/, $keys) if $keys;
263            return () if wantarray;
264    }
265    
266    =head2 randomkey
267    
268      my $key = $r->randomkey;
269    
270    =cut
271    
272    sub randomkey {
273            my ( $self ) = @_;
274            $self->_sock_send( 'RANDOMKEY' );
275    }
276    
277    =head2 rename
278    
279      my $ok = $r->rename( 'old-key', 'new-key', $new );
280    
281    =cut
282    
283    sub rename {
284            my ( $self, $old, $new, $nx ) = @_;
285            $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
286    }
287    
288    =head2 dbsize
289    
290      my $nr_keys = $r->dbsize;
291    
292    =cut
293    
294    sub dbsize {
295            my ( $self ) = @_;
296            $self->_sock_send('DBSIZE');
297    }
298    
299    =head1 Commands operating on lists
300    
301    See also L<Redis::List> for tie interface.
302    
303    =head2 rpush
304    
305      $r->rpush( $key, $value );
306    
307    =cut
308    
309    sub rpush {
310            my ( $self, $key, $value ) = @_;
311            $self->_sock_send_bulk('RPUSH', $key, $value);
312    }
313    
314    =head2 lpush
315    
316      $r->lpush( $key, $value );
317    
318    =cut
319    
320    sub lpush {
321            my ( $self, $key, $value ) = @_;
322            $self->_sock_send_bulk('LPUSH', $key, $value);
323    }
324    
325    =head2 llen
326    
327      $r->llen( $key );
328    
329    =cut
330    
331    sub llen {
332            my ( $self, $key ) = @_;
333            $self->_sock_send( 'LLEN', $key );
334    }
335    
336    =head2 lrange
337    
338      my @list = $r->lrange( $key, $start, $end );
339    
340    =cut
341    
342    sub lrange {
343            my ( $self, $key, $start, $end ) = @_;
344            $self->_sock_result_bulk_list('LRANGE', $key, $start, $end);
345    }
346    
347    =head2 ltrim
348    
349      my $ok = $r->ltrim( $key, $start, $end );
350    
351    =cut
352    
353    sub ltrim {
354            my ( $self, $key, $start, $end ) = @_;
355            $self->_sock_send_ok( 'LTRIM', $key, $start, $end );
356    }
357    
358    =head2 lindex
359    
360      $r->lindex( $key, $index );
361    
362    =cut
363    
364    sub lindex {
365            my ( $self, $key, $index ) = @_;
366            $self->_sock_result_bulk( 'LINDEX', $key, $index );
367    }
368    
369    =head2 lset
370    
371      $r->lset( $key, $index, $value );
372    
373    =cut
374    
375    sub lset {
376            my ( $self, $key, $index, $value ) = @_;
377            $self->_sock_send_bulk( 'LSET', $key, $index, $value );
378    }
379    
380    =head2 lrem
381    
382      my $modified_count = $r->lrem( $key, $count, $value );
383    
384    =cut
385    
386    sub lrem {
387            my ( $self, $key, $count, $value ) = @_;
388            $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );
389    }
390    
391    =head2 lpop
392    
393      my $value = $r->lpop( $key );
394    
395    =cut
396    
397    sub lpop {
398            my ( $self, $key ) = @_;
399            $self->_sock_result_bulk( 'LPOP', $key );
400    }
401    
402    =head2 rpop
403    
404      my $value = $r->rpop( $key );
405    
406    =cut
407    
408    sub rpop {
409            my ( $self, $key ) = @_;
410            $self->_sock_result_bulk( 'RPOP', $key );
411    }
412    
413    =head1 Commands operating on sets
414    
415    =head2 sadd
416    
417      $r->sadd( $key, $member );
418    
419    =cut
420    
421    sub sadd {
422            my ( $self, $key, $member ) = @_;
423            $self->_sock_send_bulk_number( 'SADD', $key, $member );
424    }
425    
426    =head2 srem
427    
428      $r->srem( $key, $member );
429    
430    =cut
431    
432    sub srem {
433            my ( $self, $key, $member ) = @_;
434            $self->_sock_send_bulk_number( 'SREM', $key, $member );
435    }
436    
437    =head2 scard
438    
439      my $elements = $r->scard( $key );
440    
441    =cut
442    
443    sub scard {
444            my ( $self, $key ) = @_;
445            $self->_sock_send( 'SCARD', $key );
446    }
447    
448    =head2 sismember
449    
450      $r->sismember( $key, $member );
451    
452    =cut
453    
454    sub sismember {
455            my ( $self, $key, $member ) = @_;
456            $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member );
457    }
458    
459    =head2 sinter
460    
461      $r->sinter( $key1, $key2, ... );
462    
463    =cut
464    
465    sub sinter {
466            my $self = shift;
467            $self->_sock_result_bulk_list( 'SINTER', @_ );
468    }
469    
470    =head2 sinterstore
471    
472      my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
473    
474    =cut
475    
476    sub sinterstore {
477            my $self = shift;
478            $self->_sock_send_ok( 'SINTERSTORE', @_ );
479    }
480    
481    =head1 Multiple databases handling commands
482    
483    =head2 select
484    
485      $r->select( $dbindex ); # 0 for new clients
486    
487    =cut
488    
489    sub select {
490            my ($self,$dbindex) = @_;
491            confess dump($dbindex) . 'not number' unless $dbindex =~ m{^\d+$};
492            $self->_sock_send_ok( 'SELECT', $dbindex );
493    }
494    
495    =head2 move
496    
497      $r->move( $key, $dbindex );
498    
499    =cut
500    
501    sub move {
502            my ( $self, $key, $dbindex ) = @_;
503            $self->_sock_send( 'MOVE', $key, $dbindex );
504    }
505    
506    =head2 flushdb
507    
508      $r->flushdb;
509    
510    =cut
511    
512    sub flushdb {
513            my $self = shift;
514            $self->_sock_send_ok('FLUSHDB');
515    }
516    
517    =head2 flushall
518    
519      $r->flushall;
520    
521    =cut
522    
523    sub flushall {
524            my $self = shift;
525            $self->_sock_send_ok('flushall');
526  }  }
527    
528  =head1 AUTHOR  =head1 AUTHOR
Legend:
Removed from v.9  
changed lines
  Added in v.43
  ViewVC Help
Powered by ViewVC 1.1.26