/[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 28 - (hide annotations)
Sun Mar 22 15:02:42 2009 UTC (10 years, 8 months ago) by dpavlin
File size: 6863 byte(s)
support for set foo => undef
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 26 sub __sock_ok {
83 dpavlin 14 my $ok = <$sock>;
84 dpavlin 28 return undef if $ok eq "nil\r\n";
85 dpavlin 14 confess dump($ok) unless $ok eq "+OK\r\n";
86     }
87    
88 dpavlin 20 sub _sock_send {
89     my $self = shift;
90 dpavlin 21 warn "## _sock_send ",dump( @_ );
91 dpavlin 20 print $sock join(' ',@_) . "\r\n";
92     _sock_result();
93     }
94    
95 dpavlin 21 sub _sock_send_ok {
96     my $self = shift;
97     warn "## _sock_send_ok ",dump( @_ );
98     print $sock join(' ',@_) . "\r\n";
99 dpavlin 26 __sock_ok();
100 dpavlin 21 }
101    
102 dpavlin 26 sub __sock_send_bulk_raw {
103 dpavlin 24 my $self = shift;
104 dpavlin 26 warn "## _sock_send_bulk ",dump( @_ );
105 dpavlin 24 my $value = pop;
106 dpavlin 28 $value = '' unless defined $value; # FIXME errr? nil?
107     print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n"
108 dpavlin 18 }
109    
110 dpavlin 26 sub _sock_send_bulk {
111     __sock_send_bulk_raw( @_ );
112     __sock_ok();
113     }
114 dpavlin 18
115 dpavlin 26 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 dpavlin 2 =head1 Connection Handling
123 dpavlin 1
124 dpavlin 2 =head2 quit
125    
126     $r->quit;
127    
128 dpavlin 1 =cut
129    
130 dpavlin 2 sub quit {
131     my $self = shift;
132    
133     close( $sock ) || warn $!;
134 dpavlin 1 }
135    
136 dpavlin 2 =head2 ping
137    
138 dpavlin 3 $r->ping || die "no server?";
139 dpavlin 2
140     =cut
141    
142     sub ping {
143     print $sock "PING\r\n";
144     my $pong = <$sock>;
145     die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
146     }
147    
148 dpavlin 3 =head1 Commands operating on string values
149    
150     =head2 set
151    
152 dpavlin 5 $r->set( foo => 'bar', $new );
153 dpavlin 3
154     =cut
155    
156     sub set {
157 dpavlin 18 my ( $self, $key, $value, $new ) = @_;
158     $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
159 dpavlin 3 }
160    
161     =head2 get
162    
163     my $value = $r->get( 'foo' );
164    
165     =cut
166    
167     sub get {
168 dpavlin 21 my $self = shift;
169     $self->_sock_result_bulk('GET', @_);
170 dpavlin 3 }
171    
172 dpavlin 7 =head2 incr
173 dpavlin 4
174 dpavlin 7 $r->incr('counter');
175     $r->incr('tripplets', 3);
176 dpavlin 4
177 dpavlin 7 =cut
178    
179 dpavlin 10
180    
181 dpavlin 7 sub incr {
182 dpavlin 21 my $self = shift;
183     $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
184 dpavlin 7 }
185    
186 dpavlin 8 =head2 decr
187    
188     $r->decr('counter');
189     $r->decr('tripplets', 3);
190    
191     =cut
192    
193     sub decr {
194 dpavlin 21 my $self = shift;
195     $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
196 dpavlin 8 }
197    
198 dpavlin 9 =head2 exists
199    
200     $r->exists( 'key' ) && print "got key!";
201    
202     =cut
203    
204     sub exists {
205     my ( $self, $key ) = @_;
206 dpavlin 21 $self->_sock_send( 'EXISTS', $key );
207 dpavlin 9 }
208    
209 dpavlin 10 =head2 del
210    
211     $r->del( 'key' ) || warn "key doesn't exist";
212    
213     =cut
214    
215     sub del {
216     my ( $self, $key ) = @_;
217 dpavlin 21 $self->_sock_send( 'DEL', $key );
218 dpavlin 10 }
219    
220 dpavlin 11 =head2 type
221    
222     $r->type( 'key' ); # = string
223    
224     =cut
225    
226     sub type {
227     my ( $self, $key ) = @_;
228 dpavlin 21 $self->_sock_send( 'TYPE', $key );
229 dpavlin 11 }
230    
231 dpavlin 12 =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 dpavlin 21 return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
242 dpavlin 12 }
243    
244 dpavlin 13 =head2 randomkey
245    
246     my $key = $r->randomkey;
247    
248     =cut
249    
250     sub randomkey {
251 dpavlin 14 my ( $self ) = @_;
252 dpavlin 21 $self->_sock_send( 'RANDOMKEY' );
253 dpavlin 13 }
254    
255 dpavlin 14 =head2 rename
256    
257 dpavlin 15 my $ok = $r->rename( 'old-key', 'new-key', $new );
258 dpavlin 14
259     =cut
260    
261     sub rename {
262     my ( $self, $old, $new, $nx ) = @_;
263 dpavlin 21 $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
264 dpavlin 14 }
265    
266 dpavlin 17 =head2 dbsize
267    
268     my $nr_keys = $r->dbsize;
269    
270     =cut
271    
272     sub dbsize {
273     my ( $self ) = @_;
274 dpavlin 21 $self->_sock_send('DBSIZE');
275 dpavlin 17 }
276    
277 dpavlin 18 =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 dpavlin 19 =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 dpavlin 20 =head2 llen
302    
303     $r->llen( $key );
304    
305     =cut
306    
307     sub llen {
308     my ( $self, $key ) = @_;
309 dpavlin 21 $self->_sock_send( 'LLEN', $key );
310 dpavlin 20 }
311    
312 dpavlin 21 =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 dpavlin 22 =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 dpavlin 23 =head2 lindex
346    
347     $r->lindex( $key, $index );
348    
349     =cut
350    
351     sub lindex {
352     my ( $self, $key, $index ) = @_;
353 dpavlin 24 $self->_sock_result_bulk( 'LINDEX', $key, $index );
354 dpavlin 23 }
355    
356 dpavlin 24 =head2 lset
357 dpavlin 23
358 dpavlin 24 $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 dpavlin 26 =head2 lrem
368    
369 dpavlin 27 my $modified_count = $r->lrem( $key, $count, $value );
370 dpavlin 26
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 dpavlin 27 =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 dpavlin 1 =head1 AUTHOR
401    
402     Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
403    
404     =head1 BUGS
405    
406     Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
407     the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
408     automatically be notified of progress on your bug as I make changes.
409    
410    
411    
412    
413     =head1 SUPPORT
414    
415     You can find documentation for this module with the perldoc command.
416    
417     perldoc Redis
418    
419    
420     You can also look for information at:
421    
422     =over 4
423    
424     =item * RT: CPAN's request tracker
425    
426     L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
427    
428     =item * AnnoCPAN: Annotated CPAN documentation
429    
430     L<http://annocpan.org/dist/Redis>
431    
432     =item * CPAN Ratings
433    
434     L<http://cpanratings.perl.org/d/Redis>
435    
436     =item * Search CPAN
437    
438     L<http://search.cpan.org/dist/Redis>
439    
440     =back
441    
442    
443     =head1 ACKNOWLEDGEMENTS
444    
445    
446     =head1 COPYRIGHT & LICENSE
447    
448     Copyright 2009 Dobrica Pavlinusic, all rights reserved.
449    
450     This program is free software; you can redistribute it and/or modify it
451     under the same terms as Perl itself.
452    
453    
454     =cut
455    
456     1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26