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

  ViewVC Help
Powered by ViewVC 1.1.26