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

  ViewVC Help
Powered by ViewVC 1.1.26