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