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

Contents of /lib/Redis.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 37 - (show annotations)
Sun Mar 22 18:07:46 2009 UTC (11 years, 8 months ago) by dpavlin
File size: 8201 byte(s)
REDIS enviroment variable controlls debug output
1 package Redis;
2
3 use warnings;
4 use strict;
5
6 use IO::Socket::INET;
7 use Data::Dump qw/dump/;
8 use Carp qw/confess/;
9
10 =head1 NAME
11
12 Redis - perl binding for Redis database
13
14 =cut
15
16 our $VERSION = '0.01';
17
18
19 =head1 SYNOPSIS
20
21 Pure perl bindings for L<http://code.google.com/p/redis/>
22
23 This version support git version of Redis available at
24 L<git://github.com/antirez/redis>
25
26 use Redis;
27
28 my $r = Redis->new();
29
30 =head1 FUNCTIONS
31
32 =head2 new
33
34 =cut
35
36 our $debug = $ENV{REDIS} || 0;
37
38 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 }
55
56 sub _sock_result {
57 my $result = <$sock>;
58 warn "## result: ",dump( $result ) if $debug;
59 $result =~ s{\r\n$}{} || warn "can't find cr/lf";
60 return $result;
61 }
62
63 sub _sock_read_bulk {
64 my $len = <$sock>;
65 warn "## bulk len: ",dump($len) if $debug;
66 return undef if $len eq "nil\r\n";
67 my $v;
68 if ( $len > 0 ) {
69 read($sock, $v, $len) || die $!;
70 warn "## bulk v: ",dump($v) if $debug;
71 }
72 my $crlf;
73 read($sock, $crlf, 2); # skip cr/lf
74 return $v;
75 }
76
77 sub _sock_result_bulk {
78 my $self = shift;
79 warn "## _sock_result_bulk ",dump( @_ ) if $debug;
80 print $sock join(' ',@_) . "\r\n";
81 _sock_read_bulk();
82 }
83
84 sub _sock_result_bulk_list {
85 my $self = shift;
86 warn "## _sock_result_bulk_list ",dump( @_ ) if $debug;
87
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 warn "## list = ", dump( @list ) if $debug;
98 return @list;
99 }
100
101 sub __sock_ok {
102 my $ok = <$sock>;
103 return undef if $ok eq "nil\r\n";
104 confess dump($ok) unless $ok eq "+OK\r\n";
105 }
106
107 sub _sock_send {
108 my $self = shift;
109 warn "## _sock_send ",dump( @_ ) if $debug;
110 print $sock join(' ',@_) . "\r\n";
111 _sock_result();
112 }
113
114 sub _sock_send_ok {
115 my $self = shift;
116 warn "## _sock_send_ok ",dump( @_ ) if $debug;
117 print $sock join(' ',@_) . "\r\n";
118 __sock_ok();
119 }
120
121 sub __sock_send_bulk_raw {
122 my $self = shift;
123 warn "## _sock_send_bulk ",dump( @_ ) if $debug;
124 my $value = pop;
125 $value = '' unless defined $value; # FIXME errr? nil?
126 print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n"
127 }
128
129 sub _sock_send_bulk {
130 __sock_send_bulk_raw( @_ );
131 __sock_ok();
132 }
133
134 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 =head1 Connection Handling
142
143 =head2 quit
144
145 $r->quit;
146
147 =cut
148
149 sub quit {
150 my $self = shift;
151
152 close( $sock ) || warn $!;
153 }
154
155 =head2 ping
156
157 $r->ping || die "no server?";
158
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 =head1 Commands operating on string values
168
169 =head2 set
170
171 $r->set( foo => 'bar', $new );
172
173 =cut
174
175 sub set {
176 my ( $self, $key, $value, $new ) = @_;
177 $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
178 }
179
180 =head2 get
181
182 my $value = $r->get( 'foo' );
183
184 =cut
185
186 sub get {
187 my $self = shift;
188 $self->_sock_result_bulk('GET', @_);
189 }
190
191 =head2 incr
192
193 $r->incr('counter');
194 $r->incr('tripplets', 3);
195
196 =cut
197
198
199
200 sub incr {
201 my $self = shift;
202 $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
203 }
204
205 =head2 decr
206
207 $r->decr('counter');
208 $r->decr('tripplets', 3);
209
210 =cut
211
212 sub decr {
213 my $self = shift;
214 $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
215 }
216
217 =head2 exists
218
219 $r->exists( 'key' ) && print "got key!";
220
221 =cut
222
223 sub exists {
224 my ( $self, $key ) = @_;
225 $self->_sock_send( 'EXISTS', $key );
226 }
227
228 =head2 del
229
230 $r->del( 'key' ) || warn "key doesn't exist";
231
232 =cut
233
234 sub del {
235 my ( $self, $key ) = @_;
236 $self->_sock_send( 'DEL', $key );
237 }
238
239 =head2 type
240
241 $r->type( 'key' ); # = string
242
243 =cut
244
245 sub type {
246 my ( $self, $key ) = @_;
247 $self->_sock_send( 'TYPE', $key );
248 }
249
250 =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 return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
261 }
262
263 =head2 randomkey
264
265 my $key = $r->randomkey;
266
267 =cut
268
269 sub randomkey {
270 my ( $self ) = @_;
271 $self->_sock_send( 'RANDOMKEY' );
272 }
273
274 =head2 rename
275
276 my $ok = $r->rename( 'old-key', 'new-key', $new );
277
278 =cut
279
280 sub rename {
281 my ( $self, $old, $new, $nx ) = @_;
282 $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
283 }
284
285 =head2 dbsize
286
287 my $nr_keys = $r->dbsize;
288
289 =cut
290
291 sub dbsize {
292 my ( $self ) = @_;
293 $self->_sock_send('DBSIZE');
294 }
295
296 =head1 Commands operating on lists
297
298 See also L<Redis::List> for tie interface.
299
300 =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 =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 =head2 llen
323
324 $r->llen( $key );
325
326 =cut
327
328 sub llen {
329 my ( $self, $key ) = @_;
330 $self->_sock_send( 'LLEN', $key );
331 }
332
333 =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 $self->_sock_result_bulk_list('LRANGE', $key, $start, $end);
342 }
343
344 =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 =head2 lindex
356
357 $r->lindex( $key, $index );
358
359 =cut
360
361 sub lindex {
362 my ( $self, $key, $index ) = @_;
363 $self->_sock_result_bulk( 'LINDEX', $key, $index );
364 }
365
366 =head2 lset
367
368 $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 =head2 lrem
378
379 my $modified_count = $r->lrem( $key, $count, $value );
380
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 =head2 lpop
389
390 my $value = $r->lpop( $key );
391
392 =cut
393
394 sub lpop {
395 my ( $self, $key ) = @_;
396 $self->_sock_result_bulk( 'LPOP', $key );
397 }
398
399 =head2 rpop
400
401 my $value = $r->rpop( $key );
402
403 =cut
404
405 sub rpop {
406 my ( $self, $key ) = @_;
407 $self->_sock_result_bulk( 'RPOP', $key );
408 }
409
410 =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 =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 =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 =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 =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 =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