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

  ViewVC Help
Powered by ViewVC 1.1.26