/[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 30 by dpavlin, Sun Mar 22 17:02:46 2009 UTC
# Line 58  sub _sock_result { Line 58  sub _sock_result {
58          return $result;          return $result;
59  }  }
60    
61  sub _sock_result_bulk {  sub _sock_read_bulk {
62          my $len = <$sock>;          my $len = <$sock>;
63          warn "# len: ",dump($len);          warn "## bulk len: ",dump($len);
64          return undef if $len eq "nil\r\n";          return undef if $len eq "nil\r\n";
65          my $v;          my $v;
66          read($sock, $v, $len) || die $!;          if ( $len > 0 ) {
67          warn "# v: ",dump($v);                  read($sock, $v, $len) || die $!;
68                    warn "## bulk v: ",dump($v);
69            }
70          my $crlf;          my $crlf;
71          read($sock, $crlf, 2); # skip cr/lf          read($sock, $crlf, 2); # skip cr/lf
72          return $v;          return $v;
73  }  }
74    
75  sub _sock_ok {  sub _sock_result_bulk {
76            my $self = shift;
77            warn "## _sock_result_bulk ",dump( @_ );
78            print $sock join(' ',@_) . "\r\n";
79            _sock_read_bulk();
80    }
81    
82    sub __sock_ok {
83          my $ok = <$sock>;          my $ok = <$sock>;
84            return undef if $ok eq "nil\r\n";
85          confess dump($ok) unless $ok eq "+OK\r\n";          confess dump($ok) unless $ok eq "+OK\r\n";
86  }  }
87    
88    sub _sock_send {
89            my $self = shift;
90            warn "## _sock_send ",dump( @_ );
91            print $sock join(' ',@_) . "\r\n";
92            _sock_result();
93    }
94    
95    sub _sock_send_ok {
96            my $self = shift;
97            warn "## _sock_send_ok ",dump( @_ );
98            print $sock join(' ',@_) . "\r\n";
99            __sock_ok();
100    }
101    
102    sub __sock_send_bulk_raw {
103            my $self = shift;
104            warn "## _sock_send_bulk ",dump( @_ );
105            my $value = pop;
106            $value = '' unless defined $value; # FIXME errr? nil?
107            print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n"
108    }
109    
110  sub _sock_send_bulk {  sub _sock_send_bulk {
111          my ( $self, $command, $key, $value ) = @_;          __sock_send_bulk_raw( @_ );
112          print $sock "$command $key " . length($value) . "\r\n$value\r\n";          __sock_ok();
         _sock_ok();  
113  }  }
114    
115    sub _sock_send_bulk_number {
116            __sock_send_bulk_raw( @_ );
117            my $v = _sock_result();
118            confess $v unless $v =~ m{^\-?\d+$};
119            return $v;
120    }
121    
122  =head1 Connection Handling  =head1 Connection Handling
123    
# Line 128  sub set { Line 165  sub set {
165  =cut  =cut
166    
167  sub get {  sub get {
168          my ( $self, $k ) = @_;          my $self = shift;
169          print $sock "GET $k\r\n";          $self->_sock_result_bulk('GET', @_);
         _sock_result_bulk();  
170  }  }
171    
172  =head2 incr  =head2 incr
# Line 143  sub get { Line 179  sub get {
179                    
180    
181  sub incr {  sub incr {
182          my ( $self, $key, $value ) = @_;          my $self = shift;
183          if ( defined $value ) {          $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
                 print $sock "INCRBY $key $value\r\n";  
         } else {  
                 print $sock "INCR $key\r\n";  
         }  
         _sock_result();  
184  }  }
185    
186  =head2 decr  =head2 decr
# Line 160  sub incr { Line 191  sub incr {
191  =cut  =cut
192    
193  sub decr {  sub decr {
194          my ( $self, $key, $value ) = @_;          my $self = shift;
195          if ( defined $value ) {          $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
                 print $sock "DECRBY $key $value\r\n";  
         } else {  
                 print $sock "DECR $key\r\n";  
         }  
         _sock_result();  
196  }  }
197    
198  =head2 exists  =head2 exists
# Line 177  sub decr { Line 203  sub decr {
203    
204  sub exists {  sub exists {
205          my ( $self, $key ) = @_;          my ( $self, $key ) = @_;
206          print $sock "EXISTS $key\r\n";          $self->_sock_send( 'EXISTS', $key );
         _sock_result();  
207  }  }
208    
209  =head2 del  =head2 del
# Line 189  sub exists { Line 214  sub exists {
214    
215  sub del {  sub del {
216          my ( $self, $key ) = @_;          my ( $self, $key ) = @_;
217          print $sock "DEL $key\r\n";          $self->_sock_send( 'DEL', $key );
         _sock_result();  
218  }  }
219    
220  =head2 type  =head2 type
# Line 201  sub del { Line 225  sub del {
225    
226  sub type {  sub type {
227          my ( $self, $key ) = @_;          my ( $self, $key ) = @_;
228          print $sock "TYPE $key\r\n";          $self->_sock_send( 'TYPE', $key );
         _sock_result();  
229  }  }
230    
231  =head1 Commands operating on the key space  =head1 Commands operating on the key space
# Line 215  sub type { Line 238  sub type {
238    
239  sub keys {  sub keys {
240          my ( $self, $glob ) = @_;          my ( $self, $glob ) = @_;
241          print $sock "KEYS $glob\r\n";          return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
         return split(/\s/, _sock_result_bulk());  
242  }  }
243    
244  =head2 randomkey  =head2 randomkey
# Line 227  sub keys { Line 249  sub keys {
249    
250  sub randomkey {  sub randomkey {
251          my ( $self ) = @_;          my ( $self ) = @_;
252          print $sock "RANDOMKEY\r\n";          $self->_sock_send( 'RANDOMKEY' );
         _sock_result();  
253  }  }
254    
255  =head2 rename  =head2 rename
# Line 239  sub randomkey { Line 260  sub randomkey {
260    
261  sub rename {  sub rename {
262          my ( $self, $old, $new, $nx ) = @_;          my ( $self, $old, $new, $nx ) = @_;
263          print $sock "RENAME" . ( $nx ? 'NX' : '' ) . " $old $new\r\n";          $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
         _sock_ok();  
264  }  }
265    
266  =head2 dbsize  =head2 dbsize
# Line 251  sub rename { Line 271  sub rename {
271    
272  sub dbsize {  sub dbsize {
273          my ( $self ) = @_;          my ( $self ) = @_;
274          print $sock "DBSIZE\r\n";          $self->_sock_send('DBSIZE');
         _sock_result();  
275  }  }
276    
277  =head1 Commands operating on lists  =head1 Commands operating on lists
# Line 279  sub lpush { Line 298  sub lpush {
298          $self->_sock_send_bulk('LPUSH', $key, $value);          $self->_sock_send_bulk('LPUSH', $key, $value);
299  }  }
300    
301    =head2 llen
302    
303      $r->llen( $key );
304    
305    =cut
306    
307    sub llen {
308            my ( $self, $key ) = @_;
309            $self->_sock_send( 'LLEN', $key );
310    }
311    
312    =head2 lrange
313    
314      my @list = $r->lrange( $key, $start, $end );
315    
316    =cut
317    
318    sub lrange {
319            my ( $self, $key, $start, $end ) = @_;
320            my $size = $self->_sock_send('LRANGE', $key, $start, $end);
321    
322            confess $size unless $size > 0;
323            $size--;
324    
325            my @list = ( 0 .. $size );
326            foreach ( 0 .. $size ) {
327                    $list[ $_ ] = _sock_read_bulk();
328            }
329    
330            warn "## lrange $key $start $end = [$size] ", dump( @list );
331            return @list;
332    }
333    
334    =head2 ltrim
335    
336      my $ok = $r->ltrim( $key, $start, $end );
337    
338    =cut
339    
340    sub ltrim {
341            my ( $self, $key, $start, $end ) = @_;
342            $self->_sock_send_ok( 'LTRIM', $key, $start, $end );
343    }
344    
345    =head2 lindex
346    
347      $r->lindex( $key, $index );
348    
349    =cut
350    
351    sub lindex {
352            my ( $self, $key, $index ) = @_;
353            $self->_sock_result_bulk( 'LINDEX', $key, $index );
354    }
355    
356    =head2 lset
357    
358      $r->lset( $key, $index, $value );
359    
360    =cut
361    
362    sub lset {
363            my ( $self, $key, $index, $value ) = @_;
364            $self->_sock_send_bulk( 'LSET', $key, $index, $value );
365    }
366    
367    =head2 lrem
368    
369      my $modified_count = $r->lrem( $key, $count, $value );
370    
371    =cut
372    
373    sub lrem {
374            my ( $self, $key, $count, $value ) = @_;
375            $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );
376    }
377    
378    =head2 lpop
379    
380      my $value = $r->lpop( $key );
381    
382    =cut
383    
384    sub lpop {
385            my ( $self, $key ) = @_;
386            $self->_sock_result_bulk( 'LPOP', $key );
387    }
388    
389    =head2 rpop
390    
391      my $value = $r->rpop( $key );
392    
393    =cut
394    
395    sub rpop {
396            my ( $self, $key ) = @_;
397            $self->_sock_result_bulk( 'RPOP', $key );
398    }
399    
400    =head1 Commands operating on sets
401    
402    =head2 sadd
403    
404      $r->sadd( $key, $member );
405    
406    =cut
407    
408    sub sadd {
409            my ( $self, $key, $member ) = @_;
410            $self->_sock_send_bulk_number( 'SADD', $key, $member );
411    }
412    
413    =head2 srem
414    
415      $r->srem( $key, $member );
416    
417    =cut
418    
419    sub srem {
420            my ( $self, $key, $member ) = @_;
421            $self->_sock_send_bulk_number( 'SREM', $key, $member );
422    }
423    
424  =head1 AUTHOR  =head1 AUTHOR
425    
426  Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
Legend:
Removed from v.19  
changed lines
  Added in v.30
  ViewVC Help
Powered by ViewVC 1.1.26