/[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 24 - (hide annotations)
Sun Mar 22 13:18:11 2009 UTC (10 years, 4 months ago) by dpavlin
File size: 6046 byte(s)
lset, generalize _sock_send_bulk to any number of arguments
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     read($sock, $v, $len) || die $!;
67 dpavlin 21 warn "## bulk v: ",dump($v);
68 dpavlin 12 my $crlf;
69     read($sock, $crlf, 2); # skip cr/lf
70     return $v;
71     }
72    
73 dpavlin 21 sub _sock_result_bulk {
74     my $self = shift;
75     warn "## _sock_result_bulk ",dump( @_ );
76     print $sock join(' ',@_) . "\r\n";
77     _sock_read_bulk();
78     }
79    
80 dpavlin 14 sub _sock_ok {
81     my $ok = <$sock>;
82     confess dump($ok) unless $ok eq "+OK\r\n";
83     }
84    
85 dpavlin 20 sub _sock_send {
86     my $self = shift;
87 dpavlin 21 warn "## _sock_send ",dump( @_ );
88 dpavlin 20 print $sock join(' ',@_) . "\r\n";
89     _sock_result();
90     }
91    
92 dpavlin 21 sub _sock_send_ok {
93     my $self = shift;
94     warn "## _sock_send_ok ",dump( @_ );
95     print $sock join(' ',@_) . "\r\n";
96     _sock_ok();
97     }
98    
99 dpavlin 18 sub _sock_send_bulk {
100 dpavlin 24 my $self = shift;
101     my $value = pop;
102     print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n";
103 dpavlin 18 _sock_ok();
104     }
105    
106    
107 dpavlin 2 =head1 Connection Handling
108 dpavlin 1
109 dpavlin 2 =head2 quit
110    
111     $r->quit;
112    
113 dpavlin 1 =cut
114    
115 dpavlin 2 sub quit {
116     my $self = shift;
117    
118     close( $sock ) || warn $!;
119 dpavlin 1 }
120    
121 dpavlin 2 =head2 ping
122    
123 dpavlin 3 $r->ping || die "no server?";
124 dpavlin 2
125     =cut
126    
127     sub ping {
128     print $sock "PING\r\n";
129     my $pong = <$sock>;
130     die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
131     }
132    
133 dpavlin 3 =head1 Commands operating on string values
134    
135     =head2 set
136    
137 dpavlin 5 $r->set( foo => 'bar', $new );
138 dpavlin 3
139     =cut
140    
141     sub set {
142 dpavlin 18 my ( $self, $key, $value, $new ) = @_;
143     $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
144 dpavlin 3 }
145    
146     =head2 get
147    
148     my $value = $r->get( 'foo' );
149    
150     =cut
151    
152     sub get {
153 dpavlin 21 my $self = shift;
154     $self->_sock_result_bulk('GET', @_);
155 dpavlin 3 }
156    
157 dpavlin 7 =head2 incr
158 dpavlin 4
159 dpavlin 7 $r->incr('counter');
160     $r->incr('tripplets', 3);
161 dpavlin 4
162 dpavlin 7 =cut
163    
164 dpavlin 10
165    
166 dpavlin 7 sub incr {
167 dpavlin 21 my $self = shift;
168     $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
169 dpavlin 7 }
170    
171 dpavlin 8 =head2 decr
172    
173     $r->decr('counter');
174     $r->decr('tripplets', 3);
175    
176     =cut
177    
178     sub decr {
179 dpavlin 21 my $self = shift;
180     $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
181 dpavlin 8 }
182    
183 dpavlin 9 =head2 exists
184    
185     $r->exists( 'key' ) && print "got key!";
186    
187     =cut
188    
189     sub exists {
190     my ( $self, $key ) = @_;
191 dpavlin 21 $self->_sock_send( 'EXISTS', $key );
192 dpavlin 9 }
193    
194 dpavlin 10 =head2 del
195    
196     $r->del( 'key' ) || warn "key doesn't exist";
197    
198     =cut
199    
200     sub del {
201     my ( $self, $key ) = @_;
202 dpavlin 21 $self->_sock_send( 'DEL', $key );
203 dpavlin 10 }
204    
205 dpavlin 11 =head2 type
206    
207     $r->type( 'key' ); # = string
208    
209     =cut
210    
211     sub type {
212     my ( $self, $key ) = @_;
213 dpavlin 21 $self->_sock_send( 'TYPE', $key );
214 dpavlin 11 }
215    
216 dpavlin 12 =head1 Commands operating on the key space
217    
218     =head2 keys
219    
220     my @keys = $r->keys( '*glob_pattern*' );
221    
222     =cut
223    
224     sub keys {
225     my ( $self, $glob ) = @_;
226 dpavlin 21 return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
227 dpavlin 12 }
228    
229 dpavlin 13 =head2 randomkey
230    
231     my $key = $r->randomkey;
232    
233     =cut
234    
235     sub randomkey {
236 dpavlin 14 my ( $self ) = @_;
237 dpavlin 21 $self->_sock_send( 'RANDOMKEY' );
238 dpavlin 13 }
239    
240 dpavlin 14 =head2 rename
241    
242 dpavlin 15 my $ok = $r->rename( 'old-key', 'new-key', $new );
243 dpavlin 14
244     =cut
245    
246     sub rename {
247     my ( $self, $old, $new, $nx ) = @_;
248 dpavlin 21 $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
249 dpavlin 14 }
250    
251 dpavlin 17 =head2 dbsize
252    
253     my $nr_keys = $r->dbsize;
254    
255     =cut
256    
257     sub dbsize {
258     my ( $self ) = @_;
259 dpavlin 21 $self->_sock_send('DBSIZE');
260 dpavlin 17 }
261    
262 dpavlin 18 =head1 Commands operating on lists
263    
264     =head2 rpush
265    
266     $r->rpush( $key, $value );
267    
268     =cut
269    
270     sub rpush {
271     my ( $self, $key, $value ) = @_;
272     $self->_sock_send_bulk('RPUSH', $key, $value);
273     }
274    
275 dpavlin 19 =head2 lpush
276    
277     $r->lpush( $key, $value );
278    
279     =cut
280    
281     sub lpush {
282     my ( $self, $key, $value ) = @_;
283     $self->_sock_send_bulk('LPUSH', $key, $value);
284     }
285    
286 dpavlin 20 =head2 llen
287    
288     $r->llen( $key );
289    
290     =cut
291    
292     sub llen {
293     my ( $self, $key ) = @_;
294 dpavlin 21 $self->_sock_send( 'LLEN', $key );
295 dpavlin 20 }
296    
297 dpavlin 21 =head2 lrange
298    
299     my @list = $r->lrange( $key, $start, $end );
300    
301     =cut
302    
303     sub lrange {
304     my ( $self, $key, $start, $end ) = @_;
305     my $size = $self->_sock_send('LRANGE', $key, $start, $end);
306    
307     confess $size unless $size > 0;
308     $size--;
309    
310     my @list = ( 0 .. $size );
311     foreach ( 0 .. $size ) {
312     $list[ $_ ] = _sock_read_bulk();
313     }
314    
315     warn "## lrange $key $start $end = [$size] ", dump( @list );
316     return @list;
317     }
318    
319 dpavlin 22 =head2 ltrim
320    
321     my $ok = $r->ltrim( $key, $start, $end );
322    
323     =cut
324    
325     sub ltrim {
326     my ( $self, $key, $start, $end ) = @_;
327     $self->_sock_send_ok( 'LTRIM', $key, $start, $end );
328     }
329    
330 dpavlin 23 =head2 lindex
331    
332     $r->lindex( $key, $index );
333    
334     =cut
335    
336     sub lindex {
337     my ( $self, $key, $index ) = @_;
338 dpavlin 24 $self->_sock_result_bulk( 'LINDEX', $key, $index );
339 dpavlin 23 }
340    
341 dpavlin 24 =head2 lset
342 dpavlin 23
343 dpavlin 24 $r->lset( $key, $index, $value );
344    
345     =cut
346    
347     sub lset {
348     my ( $self, $key, $index, $value ) = @_;
349     $self->_sock_send_bulk( 'LSET', $key, $index, $value );
350     }
351    
352 dpavlin 1 =head1 AUTHOR
353    
354     Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
355    
356     =head1 BUGS
357    
358     Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
359     the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
360     automatically be notified of progress on your bug as I make changes.
361    
362    
363    
364    
365     =head1 SUPPORT
366    
367     You can find documentation for this module with the perldoc command.
368    
369     perldoc Redis
370    
371    
372     You can also look for information at:
373    
374     =over 4
375    
376     =item * RT: CPAN's request tracker
377    
378     L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
379    
380     =item * AnnoCPAN: Annotated CPAN documentation
381    
382     L<http://annocpan.org/dist/Redis>
383    
384     =item * CPAN Ratings
385    
386     L<http://cpanratings.perl.org/d/Redis>
387    
388     =item * Search CPAN
389    
390     L<http://search.cpan.org/dist/Redis>
391    
392     =back
393    
394    
395     =head1 ACKNOWLEDGEMENTS
396    
397    
398     =head1 COPYRIGHT & LICENSE
399    
400     Copyright 2009 Dobrica Pavlinusic, all rights reserved.
401    
402     This program is free software; you can redistribute it and/or modify it
403     under the same terms as Perl itself.
404    
405    
406     =cut
407    
408     1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26