/[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

Annotation of /lib/Redis.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 35 - (hide annotations)
Sun Mar 22 17:53:57 2009 UTC (15 years ago) by dpavlin
File size: 7980 byte(s)
added link to Redis::List
1 dpavlin 1 package Redis;
2    
3     use warnings;
4     use strict;
5    
6 dpavlin 2 use IO::Socket::INET;
7     use Data::Dump qw/dump/;
8 dpavlin 5 use Carp qw/confess/;
9 dpavlin 2
10 dpavlin 1 =head1 NAME
11    
12     Redis - The great new Redis!
13    
14     =cut
15    
16     our $VERSION = '0.01';
17    
18    
19     =head1 SYNOPSIS
20    
21 dpavlin 2 Pure perl bindings for L<http://code.google.com/p/redis/>
22 dpavlin 1
23     use Redis;
24    
25 dpavlin 2 my $r = Redis->new();
26 dpavlin 1
27    
28    
29 dpavlin 2
30 dpavlin 1 =head1 FUNCTIONS
31    
32 dpavlin 2 =head2 new
33 dpavlin 1
34     =cut
35    
36 dpavlin 2 our $sock;
37     my $server = '127.0.0.1:6379';
38    
39     sub new {
40     my $class = shift;
41     my $self = {};
42     bless($self, $class);
43    
44     warn "# opening socket to $server";
45    
46     $sock ||= IO::Socket::INET->new(
47     PeerAddr => $server,
48     Proto => 'tcp',
49     ) || die $!;
50    
51     $self;
52 dpavlin 1 }
53    
54 dpavlin 11 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 dpavlin 21 sub _sock_read_bulk {
62 dpavlin 12 my $len = <$sock>;
63 dpavlin 21 warn "## bulk len: ",dump($len);
64 dpavlin 12 return undef if $len eq "nil\r\n";
65     my $v;
66 dpavlin 28 if ( $len > 0 ) {
67     read($sock, $v, $len) || die $!;
68     warn "## bulk v: ",dump($v);
69     }
70 dpavlin 12 my $crlf;
71     read($sock, $crlf, 2); # skip cr/lf
72     return $v;
73     }
74    
75 dpavlin 21 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 dpavlin 33 sub _sock_result_bulk_list {
83     my $self = shift;
84     warn "## _sock_result_bulk_list ",dump( @_ );
85    
86     my $size = $self->_sock_send( @_ );
87     confess $size unless $size > 0;
88     $size--;
89    
90     my @list = ( 0 .. $size );
91     foreach ( 0 .. $size ) {
92     $list[ $_ ] = _sock_read_bulk();
93     }
94    
95     warn "## list = ", dump( @list );
96     return @list;
97     }
98    
99 dpavlin 26 sub __sock_ok {
100 dpavlin 14 my $ok = <$sock>;
101 dpavlin 28 return undef if $ok eq "nil\r\n";
102 dpavlin 14 confess dump($ok) unless $ok eq "+OK\r\n";
103     }
104    
105 dpavlin 20 sub _sock_send {
106     my $self = shift;
107 dpavlin 21 warn "## _sock_send ",dump( @_ );
108 dpavlin 20 print $sock join(' ',@_) . "\r\n";
109     _sock_result();
110     }
111    
112 dpavlin 21 sub _sock_send_ok {
113     my $self = shift;
114     warn "## _sock_send_ok ",dump( @_ );
115     print $sock join(' ',@_) . "\r\n";
116 dpavlin 26 __sock_ok();
117 dpavlin 21 }
118    
119 dpavlin 26 sub __sock_send_bulk_raw {
120 dpavlin 24 my $self = shift;
121 dpavlin 26 warn "## _sock_send_bulk ",dump( @_ );
122 dpavlin 24 my $value = pop;
123 dpavlin 28 $value = '' unless defined $value; # FIXME errr? nil?
124     print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n"
125 dpavlin 18 }
126    
127 dpavlin 26 sub _sock_send_bulk {
128     __sock_send_bulk_raw( @_ );
129     __sock_ok();
130     }
131 dpavlin 18
132 dpavlin 26 sub _sock_send_bulk_number {
133     __sock_send_bulk_raw( @_ );
134     my $v = _sock_result();
135     confess $v unless $v =~ m{^\-?\d+$};
136     return $v;
137     }
138    
139 dpavlin 2 =head1 Connection Handling
140 dpavlin 1
141 dpavlin 2 =head2 quit
142    
143     $r->quit;
144    
145 dpavlin 1 =cut
146    
147 dpavlin 2 sub quit {
148     my $self = shift;
149    
150     close( $sock ) || warn $!;
151 dpavlin 1 }
152    
153 dpavlin 2 =head2 ping
154    
155 dpavlin 3 $r->ping || die "no server?";
156 dpavlin 2
157     =cut
158    
159     sub ping {
160     print $sock "PING\r\n";
161     my $pong = <$sock>;
162     die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
163     }
164    
165 dpavlin 3 =head1 Commands operating on string values
166    
167     =head2 set
168    
169 dpavlin 5 $r->set( foo => 'bar', $new );
170 dpavlin 3
171     =cut
172    
173     sub set {
174 dpavlin 18 my ( $self, $key, $value, $new ) = @_;
175     $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
176 dpavlin 3 }
177    
178     =head2 get
179    
180     my $value = $r->get( 'foo' );
181    
182     =cut
183    
184     sub get {
185 dpavlin 21 my $self = shift;
186     $self->_sock_result_bulk('GET', @_);
187 dpavlin 3 }
188    
189 dpavlin 7 =head2 incr
190 dpavlin 4
191 dpavlin 7 $r->incr('counter');
192     $r->incr('tripplets', 3);
193 dpavlin 4
194 dpavlin 7 =cut
195    
196 dpavlin 10
197    
198 dpavlin 7 sub incr {
199 dpavlin 21 my $self = shift;
200     $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
201 dpavlin 7 }
202    
203 dpavlin 8 =head2 decr
204    
205     $r->decr('counter');
206     $r->decr('tripplets', 3);
207    
208     =cut
209    
210     sub decr {
211 dpavlin 21 my $self = shift;
212     $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
213 dpavlin 8 }
214    
215 dpavlin 9 =head2 exists
216    
217     $r->exists( 'key' ) && print "got key!";
218    
219     =cut
220    
221     sub exists {
222     my ( $self, $key ) = @_;
223 dpavlin 21 $self->_sock_send( 'EXISTS', $key );
224 dpavlin 9 }
225    
226 dpavlin 10 =head2 del
227    
228     $r->del( 'key' ) || warn "key doesn't exist";
229    
230     =cut
231    
232     sub del {
233     my ( $self, $key ) = @_;
234 dpavlin 21 $self->_sock_send( 'DEL', $key );
235 dpavlin 10 }
236    
237 dpavlin 11 =head2 type
238    
239     $r->type( 'key' ); # = string
240    
241     =cut
242    
243     sub type {
244     my ( $self, $key ) = @_;
245 dpavlin 21 $self->_sock_send( 'TYPE', $key );
246 dpavlin 11 }
247    
248 dpavlin 12 =head1 Commands operating on the key space
249    
250     =head2 keys
251    
252     my @keys = $r->keys( '*glob_pattern*' );
253    
254     =cut
255    
256     sub keys {
257     my ( $self, $glob ) = @_;
258 dpavlin 21 return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
259 dpavlin 12 }
260    
261 dpavlin 13 =head2 randomkey
262    
263     my $key = $r->randomkey;
264    
265     =cut
266    
267     sub randomkey {
268 dpavlin 14 my ( $self ) = @_;
269 dpavlin 21 $self->_sock_send( 'RANDOMKEY' );
270 dpavlin 13 }
271    
272 dpavlin 14 =head2 rename
273    
274 dpavlin 15 my $ok = $r->rename( 'old-key', 'new-key', $new );
275 dpavlin 14
276     =cut
277    
278     sub rename {
279     my ( $self, $old, $new, $nx ) = @_;
280 dpavlin 21 $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
281 dpavlin 14 }
282    
283 dpavlin 17 =head2 dbsize
284    
285     my $nr_keys = $r->dbsize;
286    
287     =cut
288    
289     sub dbsize {
290     my ( $self ) = @_;
291 dpavlin 21 $self->_sock_send('DBSIZE');
292 dpavlin 17 }
293    
294 dpavlin 18 =head1 Commands operating on lists
295    
296 dpavlin 35 See also L<Redis::List> for tie interface.
297    
298 dpavlin 18 =head2 rpush
299    
300     $r->rpush( $key, $value );
301    
302     =cut
303    
304     sub rpush {
305     my ( $self, $key, $value ) = @_;
306     $self->_sock_send_bulk('RPUSH', $key, $value);
307     }
308    
309 dpavlin 19 =head2 lpush
310    
311     $r->lpush( $key, $value );
312    
313     =cut
314    
315     sub lpush {
316     my ( $self, $key, $value ) = @_;
317     $self->_sock_send_bulk('LPUSH', $key, $value);
318     }
319    
320 dpavlin 20 =head2 llen
321    
322     $r->llen( $key );
323    
324     =cut
325    
326     sub llen {
327     my ( $self, $key ) = @_;
328 dpavlin 21 $self->_sock_send( 'LLEN', $key );
329 dpavlin 20 }
330    
331 dpavlin 21 =head2 lrange
332    
333     my @list = $r->lrange( $key, $start, $end );
334    
335     =cut
336    
337     sub lrange {
338     my ( $self, $key, $start, $end ) = @_;
339 dpavlin 33 $self->_sock_result_bulk_list('LRANGE', $key, $start, $end);
340 dpavlin 21 }
341    
342 dpavlin 22 =head2 ltrim
343    
344     my $ok = $r->ltrim( $key, $start, $end );
345    
346     =cut
347    
348     sub ltrim {
349     my ( $self, $key, $start, $end ) = @_;
350     $self->_sock_send_ok( 'LTRIM', $key, $start, $end );
351     }
352    
353 dpavlin 23 =head2 lindex
354    
355     $r->lindex( $key, $index );
356    
357     =cut
358    
359     sub lindex {
360     my ( $self, $key, $index ) = @_;
361 dpavlin 24 $self->_sock_result_bulk( 'LINDEX', $key, $index );
362 dpavlin 23 }
363    
364 dpavlin 24 =head2 lset
365 dpavlin 23
366 dpavlin 24 $r->lset( $key, $index, $value );
367    
368     =cut
369    
370     sub lset {
371     my ( $self, $key, $index, $value ) = @_;
372     $self->_sock_send_bulk( 'LSET', $key, $index, $value );
373     }
374    
375 dpavlin 26 =head2 lrem
376    
377 dpavlin 27 my $modified_count = $r->lrem( $key, $count, $value );
378 dpavlin 26
379     =cut
380    
381     sub lrem {
382     my ( $self, $key, $count, $value ) = @_;
383     $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );
384     }
385    
386 dpavlin 27 =head2 lpop
387    
388     my $value = $r->lpop( $key );
389    
390     =cut
391    
392     sub lpop {
393     my ( $self, $key ) = @_;
394 dpavlin 30 $self->_sock_result_bulk( 'LPOP', $key );
395 dpavlin 27 }
396    
397     =head2 rpop
398    
399     my $value = $r->rpop( $key );
400    
401     =cut
402    
403     sub rpop {
404     my ( $self, $key ) = @_;
405 dpavlin 30 $self->_sock_result_bulk( 'RPOP', $key );
406 dpavlin 27 }
407    
408 dpavlin 30 =head1 Commands operating on sets
409    
410     =head2 sadd
411    
412     $r->sadd( $key, $member );
413    
414     =cut
415    
416     sub sadd {
417     my ( $self, $key, $member ) = @_;
418     $self->_sock_send_bulk_number( 'SADD', $key, $member );
419     }
420    
421     =head2 srem
422    
423     $r->srem( $key, $member );
424    
425     =cut
426    
427     sub srem {
428     my ( $self, $key, $member ) = @_;
429     $self->_sock_send_bulk_number( 'SREM', $key, $member );
430     }
431    
432 dpavlin 31 =head2 scard
433    
434     my $elements = $r->scard( $key );
435    
436     =cut
437    
438     sub scard {
439     my ( $self, $key ) = @_;
440     $self->_sock_send( 'SCARD', $key );
441     }
442    
443 dpavlin 32 =head2 sismember
444    
445     $r->sismember( $key, $member );
446    
447     =cut
448    
449     sub sismember {
450     my ( $self, $key, $member ) = @_;
451     $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member );
452     }
453    
454 dpavlin 33 =head2 sinter
455    
456     $r->sinter( $key1, $key2, ... );
457    
458     =cut
459    
460     sub sinter {
461     my $self = shift;
462     $self->_sock_result_bulk_list( 'SINTER', @_ );
463     }
464    
465 dpavlin 34 =head2 sinterstore
466    
467     my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
468    
469     =cut
470    
471     sub sinterstore {
472     my $self = shift;
473     $self->_sock_send_ok( 'SINTERSTORE', @_ );
474     }
475    
476 dpavlin 1 =head1 AUTHOR
477    
478     Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
479    
480     =head1 BUGS
481    
482     Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
483     the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
484     automatically be notified of progress on your bug as I make changes.
485    
486    
487    
488    
489     =head1 SUPPORT
490    
491     You can find documentation for this module with the perldoc command.
492    
493     perldoc Redis
494    
495    
496     You can also look for information at:
497    
498     =over 4
499    
500     =item * RT: CPAN's request tracker
501    
502     L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
503    
504     =item * AnnoCPAN: Annotated CPAN documentation
505    
506     L<http://annocpan.org/dist/Redis>
507    
508     =item * CPAN Ratings
509    
510     L<http://cpanratings.perl.org/d/Redis>
511    
512     =item * Search CPAN
513    
514     L<http://search.cpan.org/dist/Redis>
515    
516     =back
517    
518    
519     =head1 ACKNOWLEDGEMENTS
520    
521    
522     =head1 COPYRIGHT & LICENSE
523    
524     Copyright 2009 Dobrica Pavlinusic, all rights reserved.
525    
526     This program is free software; you can redistribute it and/or modify it
527     under the same terms as Perl itself.
528    
529    
530     =cut
531    
532     1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26