/[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 71 - (show annotations)
Fri Mar 19 14:38:13 2010 UTC (9 years, 3 months ago) by dpavlin
File size: 7353 byte(s)
added encoding notice
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 ENCODING
376
377 Since Redis knows nothing about encoding, we are forcing utf-8 flag on all data received from Redis.
378 This change is introduced in 1.2001 version.
379
380 This allows us to round-trip utf-8 encoded characters correctly, but might be problem if you push
381 binary junk into Redis and expect to get it back without utf-8 flag turned on.
382
383 =head1 AUTHOR
384
385 Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
386
387 =head1 BUGS
388
389 Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
390 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
391 automatically be notified of progress on your bug as I make changes.
392
393
394
395
396 =head1 SUPPORT
397
398 You can find documentation for this module with the perldoc command.
399
400 perldoc Redis
401 perldoc Redis::List
402 perldoc Redis::Hash
403
404
405 You can also look for information at:
406
407 =over 4
408
409 =item * RT: CPAN's request tracker
410
411 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
412
413 =item * AnnoCPAN: Annotated CPAN documentation
414
415 L<http://annocpan.org/dist/Redis>
416
417 =item * CPAN Ratings
418
419 L<http://cpanratings.perl.org/d/Redis>
420
421 =item * Search CPAN
422
423 L<http://search.cpan.org/dist/Redis>
424
425 =back
426
427
428 =head1 ACKNOWLEDGEMENTS
429
430
431 =head1 COPYRIGHT & LICENSE
432
433 Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
434
435 This program is free software; you can redistribute it and/or modify it
436 under the same terms as Perl itself.
437
438
439 =cut
440
441 1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26