/[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 2 by dpavlin, Sat Mar 21 21:25:52 2009 UTC revision 30 by dpavlin, Sun Mar 22 17:02:46 2009 UTC
# Line 5  use strict; Line 5  use strict;
5    
6  use IO::Socket::INET;  use IO::Socket::INET;
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8    use Carp qw/confess/;
9    
10  =head1 NAME  =head1 NAME
11    
# Line 50  sub new { Line 51  sub new {
51          $self;          $self;
52  }  }
53    
54    sub _sock_result {
55            my $result = <$sock>;
56            warn "# result: ",dump( $result );
57            $result =~ s{\r\n$}{} || warn "can't find cr/lf";
58            return $result;
59    }
60    
61    sub _sock_read_bulk {
62            my $len = <$sock>;
63            warn "## bulk len: ",dump($len);
64            return undef if $len eq "nil\r\n";
65            my $v;
66            if ( $len > 0 ) {
67                    read($sock, $v, $len) || die $!;
68                    warn "## bulk v: ",dump($v);
69            }
70            my $crlf;
71            read($sock, $crlf, 2); # skip cr/lf
72            return $v;
73    }
74    
75    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>;
84            return undef if $ok eq "nil\r\n";
85            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 {
111            __sock_send_bulk_raw( @_ );
112            __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    
124  =head2 quit  =head2 quit
# Line 66  sub quit { Line 135  sub quit {
135    
136  =head2 ping  =head2 ping
137    
138          $r->ping || die "no server?";    $r->ping || die "no server?";
139    
140  =cut  =cut
141    
# Line 76  sub ping { Line 145  sub ping {
145          die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";          die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
146  }  }
147    
148    =head1 Commands operating on string values
149    
150    =head2 set
151    
152      $r->set( foo => 'bar', $new );
153    
154    =cut
155    
156    sub set {
157            my ( $self, $key, $value, $new ) = @_;
158            $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
159    }
160    
161    =head2 get
162    
163      my $value = $r->get( 'foo' );
164    
165    =cut
166    
167    sub get {
168            my $self = shift;
169            $self->_sock_result_bulk('GET', @_);
170    }
171    
172    =head2 incr
173    
174      $r->incr('counter');
175      $r->incr('tripplets', 3);
176    
177    =cut
178    
179            
180    
181    sub incr {
182            my $self = shift;
183            $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
184    }
185    
186    =head2 decr
187    
188      $r->decr('counter');
189      $r->decr('tripplets', 3);
190    
191    =cut
192    
193    sub decr {
194            my $self = shift;
195            $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
196    }
197    
198    =head2 exists
199    
200      $r->exists( 'key' ) && print "got key!";
201    
202    =cut
203    
204    sub exists {
205            my ( $self, $key ) = @_;
206            $self->_sock_send( 'EXISTS', $key );
207    }
208    
209    =head2 del
210    
211      $r->del( 'key' ) || warn "key doesn't exist";
212    
213    =cut
214    
215    sub del {
216            my ( $self, $key ) = @_;
217            $self->_sock_send( 'DEL', $key );
218    }
219    
220    =head2 type
221    
222      $r->type( 'key' ); # = string
223    
224    =cut
225    
226    sub type {
227            my ( $self, $key ) = @_;
228            $self->_sock_send( 'TYPE', $key );
229    }
230    
231    =head1 Commands operating on the key space
232    
233    =head2 keys
234    
235      my @keys = $r->keys( '*glob_pattern*' );
236    
237    =cut
238    
239    sub keys {
240            my ( $self, $glob ) = @_;
241            return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
242    }
243    
244    =head2 randomkey
245    
246      my $key = $r->randomkey;
247    
248    =cut
249    
250    sub randomkey {
251            my ( $self ) = @_;
252            $self->_sock_send( 'RANDOMKEY' );
253    }
254    
255    =head2 rename
256    
257      my $ok = $r->rename( 'old-key', 'new-key', $new );
258    
259    =cut
260    
261    sub rename {
262            my ( $self, $old, $new, $nx ) = @_;
263            $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
264    }
265    
266    =head2 dbsize
267    
268      my $nr_keys = $r->dbsize;
269    
270    =cut
271    
272    sub dbsize {
273            my ( $self ) = @_;
274            $self->_sock_send('DBSIZE');
275    }
276    
277    =head1 Commands operating on lists
278    
279    =head2 rpush
280    
281      $r->rpush( $key, $value );
282    
283    =cut
284    
285    sub rpush {
286            my ( $self, $key, $value ) = @_;
287            $self->_sock_send_bulk('RPUSH', $key, $value);
288    }
289    
290    =head2 lpush
291    
292      $r->lpush( $key, $value );
293    
294    =cut
295    
296    sub lpush {
297            my ( $self, $key, $value ) = @_;
298            $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.2  
changed lines
  Added in v.30
  ViewVC Help
Powered by ViewVC 1.1.26