use Encode::_utf8_on to mark bytes from Redis socket as utf-8 chars
[perl-Redis.git] / lib / Redis.pm
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