/[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 66 - (show annotations)
Wed Mar 17 16:58:00 2010 UTC (14 years ago) by dpavlin
File size: 6934 byte(s)
version bump [1.2001]

1 package Redis;
2
3 use warnings;
4 use strict;
5
6 use IO::Socket::INET;
7 use Data::Dumper;
8 use Carp qw/confess/;
9
10 =head1 NAME
11
12 Redis - perl binding for Redis database
13
14 =cut
15
16 our $VERSION = '1.2001';
17
18
19 =head1 DESCRIPTION
20
21 Pure perl bindings for L<http://code.google.com/p/redis/>
22
23 This version supports protocol 1.2 or later of Redis available at
24
25 L<git://github.com/antirez/redis>
26
27 This documentation
28 lists commands which are exercised in test suite, but
29 additinal commands will work correctly since protocol
30 specifies enough information to support almost all commands
31 with same peace of code with a little help of C<AUTOLOAD>.
32
33 =head1 FUNCTIONS
34
35 =head2 new
36
37 my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
38
39 my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
40
41 =cut
42
43 sub new {
44 my $class = shift;
45 my $self = {@_};
46 $self->{debug} ||= $ENV{REDIS_DEBUG};
47
48 $self->{sock} = IO::Socket::INET->new(
49 PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
50 Proto => 'tcp',
51 ) || die $!;
52
53 bless($self, $class);
54 $self;
55 }
56
57 my $bulk_command = {
58 set => 1, setnx => 1,
59 rpush => 1, lpush => 1,
60 lset => 1, lrem => 1,
61 sadd => 1, srem => 1,
62 sismember => 1,
63 echo => 1,
64 getset => 1,
65 smove => 1,
66 zadd => 1,
67 zrem => 1,
68 zscore => 1,
69 zincrby => 1,
70 append => 1,
71 };
72
73 # we don't want DESTROY to fallback into AUTOLOAD
74 sub DESTROY {}
75
76 our $AUTOLOAD;
77 sub AUTOLOAD {
78 my $self = shift;
79
80 my $sock = $self->{sock} || die "no server connected";
81
82 my $command = $AUTOLOAD;
83 $command =~ s/.*://;
84
85 warn "## $command ",Dumper(@_) if $self->{debug};
86
87 my $send;
88
89 if ( defined $bulk_command->{$command} ) {
90 my $value = pop;
91 $value = '' if ! defined $value;
92 $send
93 = uc($command)
94 . ' '
95 . join(' ', @_)
96 . ' '
97 . length( $value )
98 . "\r\n$value\r\n"
99 ;
100 } else {
101 $send
102 = uc($command)
103 . ' '
104 . join(' ', @_)
105 . "\r\n"
106 ;
107 }
108
109 warn ">> $send" if $self->{debug};
110 print $sock $send;
111
112 if ( $command eq 'quit' ) {
113 close( $sock ) || die "can't close socket: $!";
114 return 1;
115 }
116
117 my $result = <$sock> || die "can't read socket: $!";
118 warn "<< $result" if $self->{debug};
119 my $type = substr($result,0,1);
120 $result = substr($result,1,-2);
121
122 if ( $command eq 'info' ) {
123 my $hash;
124 foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
125 my ($n,$v) = split(/:/, $l, 2);
126 $hash->{$n} = $v;
127 }
128 return $hash;
129 } elsif ( $command eq 'keys' ) {
130 my $keys = $self->__read_bulk($result);
131 return split(/\s/, $keys) if $keys;
132 return;
133 }
134
135 if ( $type eq '-' ) {
136 confess "[$command] $result";
137 } elsif ( $type eq '+' ) {
138 return $result;
139 } elsif ( $type eq '$' ) {
140 return $self->__read_bulk($result);
141 } elsif ( $type eq '*' ) {
142 return $self->__read_multi_bulk($result);
143 } elsif ( $type eq ':' ) {
144 return $result; # FIXME check if int?
145 } else {
146 confess "unknown type: $type", $self->__read_line();
147 }
148 }
149
150 sub __read_bulk {
151 my ($self,$len) = @_;
152 return undef if $len < 0;
153
154 my $v;
155 if ( $len > 0 ) {
156 read($self->{sock}, $v, $len) || die $!;
157 warn "<< ",Dumper($v),$/ if $self->{debug};
158 }
159 my $crlf;
160 read($self->{sock}, $crlf, 2); # skip cr/lf
161 return $v;
162 }
163
164 sub __read_multi_bulk {
165 my ($self,$size) = @_;
166 return undef if $size < 0;
167 my $sock = $self->{sock};
168
169 $size--;
170
171 my @list = ( 0 .. $size );
172 foreach ( 0 .. $size ) {
173 $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
174 }
175
176 warn "## list = ", Dumper( @list ) if $self->{debug};
177 return @list;
178 }
179
180 1;
181
182 __END__
183
184 =head1 Connection Handling
185
186 =head2 quit
187
188 $r->quit;
189
190 =head2 ping
191
192 $r->ping || die "no server?";
193
194 =head1 Commands operating on string values
195
196 =head2 set
197
198 $r->set( foo => 'bar' );
199
200 $r->setnx( foo => 42 );
201
202 =head2 get
203
204 my $value = $r->get( 'foo' );
205
206 =head2 mget
207
208 my @values = $r->mget( 'foo', 'bar', 'baz' );
209
210 =head2 incr
211
212 $r->incr('counter');
213
214 $r->incrby('tripplets', 3);
215
216 =head2 decr
217
218 $r->decr('counter');
219
220 $r->decrby('tripplets', 3);
221
222 =head2 exists
223
224 $r->exists( 'key' ) && print "got key!";
225
226 =head2 del
227
228 $r->del( 'key' ) || warn "key doesn't exist";
229
230 =head2 type
231
232 $r->type( 'key' ); # = string
233
234 =head1 Commands operating on the key space
235
236 =head2 keys
237
238 my @keys = $r->keys( '*glob_pattern*' );
239
240 =head2 randomkey
241
242 my $key = $r->randomkey;
243
244 =head2 rename
245
246 my $ok = $r->rename( 'old-key', 'new-key', $new );
247
248 =head2 dbsize
249
250 my $nr_keys = $r->dbsize;
251
252 =head1 Commands operating on lists
253
254 See also L<Redis::List> for tie interface.
255
256 =head2 rpush
257
258 $r->rpush( $key, $value );
259
260 =head2 lpush
261
262 $r->lpush( $key, $value );
263
264 =head2 llen
265
266 $r->llen( $key );
267
268 =head2 lrange
269
270 my @list = $r->lrange( $key, $start, $end );
271
272 =head2 ltrim
273
274 my $ok = $r->ltrim( $key, $start, $end );
275
276 =head2 lindex
277
278 $r->lindex( $key, $index );
279
280 =head2 lset
281
282 $r->lset( $key, $index, $value );
283
284 =head2 lrem
285
286 my $modified_count = $r->lrem( $key, $count, $value );
287
288 =head2 lpop
289
290 my $value = $r->lpop( $key );
291
292 =head2 rpop
293
294 my $value = $r->rpop( $key );
295
296 =head1 Commands operating on sets
297
298 =head2 sadd
299
300 $r->sadd( $key, $member );
301
302 =head2 srem
303
304 $r->srem( $key, $member );
305
306 =head2 scard
307
308 my $elements = $r->scard( $key );
309
310 =head2 sismember
311
312 $r->sismember( $key, $member );
313
314 =head2 sinter
315
316 $r->sinter( $key1, $key2, ... );
317
318 =head2 sinterstore
319
320 my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
321
322 =head1 Multiple databases handling commands
323
324 =head2 select
325
326 $r->select( $dbindex ); # 0 for new clients
327
328 =head2 move
329
330 $r->move( $key, $dbindex );
331
332 =head2 flushdb
333
334 $r->flushdb;
335
336 =head2 flushall
337
338 $r->flushall;
339
340 =head1 Sorting
341
342 =head2 sort
343
344 $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
345
346 =head1 Persistence control commands
347
348 =head2 save
349
350 $r->save;
351
352 =head2 bgsave
353
354 $r->bgsave;
355
356 =head2 lastsave
357
358 $r->lastsave;
359
360 =head2 shutdown
361
362 $r->shutdown;
363
364 =head1 Remote server control commands
365
366 =head2 info
367
368 my $info_hash = $r->info;
369
370 =head1 AUTHOR
371
372 Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
373
374 =head1 BUGS
375
376 Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
377 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
378 automatically be notified of progress on your bug as I make changes.
379
380
381
382
383 =head1 SUPPORT
384
385 You can find documentation for this module with the perldoc command.
386
387 perldoc Redis
388 perldoc Redis::List
389 perldoc Redis::Hash
390
391
392 You can also look for information at:
393
394 =over 4
395
396 =item * RT: CPAN's request tracker
397
398 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
399
400 =item * AnnoCPAN: Annotated CPAN documentation
401
402 L<http://annocpan.org/dist/Redis>
403
404 =item * CPAN Ratings
405
406 L<http://cpanratings.perl.org/d/Redis>
407
408 =item * Search CPAN
409
410 L<http://search.cpan.org/dist/Redis>
411
412 =back
413
414
415 =head1 ACKNOWLEDGEMENTS
416
417
418 =head1 COPYRIGHT & LICENSE
419
420 Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
421
422 This program is free software; you can redistribute it and/or modify it
423 under the same terms as Perl itself.
424
425
426 =cut
427
428 1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26