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
  48         $self->{debug} ||= $ENV{REDIS_DEBUG};
  49         $self->{encoding} ||= 'utf8';    ## default to lax utf8
  50
  51         $self->{server} ||= $ENV{REDIS_SERVER} || '127.0.0.1:6379';
  52         $self->{sock} = IO::Socket::INET->new(
  53                 PeerAddr => $self->{server},
  54                 Proto => 'tcp',
  55         ) || confess("Could not connect to Redis server at $self->{server}: $!");
  56
  57         return bless($self, $class);
  58 }
  59
  60 # we don't want DESTROY to fallback into AUTOLOAD
  61 sub DESTROY {}
  62
  63
  64 ### Deal with common, general case, Redis commands
  65 our $AUTOLOAD;
  66 sub AUTOLOAD {
  67         my $self = shift;
  68         my $sock = $self->{sock} || confess("Not connected to any server");
  69         my $enc = $self->{encoding};
  70         my $deb = $self->{debug};
  71
  72         my $command = $AUTOLOAD;
  73         $command =~ s/.*://;
  74
  75         $self->__send_command($command, @_);
  76
  77         my $result = <$sock> || confess("Can't read socket: $!");
  78         my $type = substr($result,0,1);
  79         $result = substr($result,1,-2);
  80
  81         $result = decode($enc, $result) if $enc;
  82         warn "[RECV] '$type$result'" if $deb;
  83
  84         if ( $command eq 'info' ) {
  85                 my $hash;
  86                 foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
  87                         my ($n,$v) = split(/:/, $l, 2);
  88                         $hash->{$n} = $v;
  89                 }
  90                 return $hash;
  91         } elsif ( $command eq 'keys' ) {
  92                 return $self->__read_multi_bulk($result)
  93                         if $type eq '*';
  94                 my $keys = $self->__read_bulk($result);
  95                 return split(/\s/, $keys) if $keys;
  96                 return;
  97         }
  98
  99         if ( $type eq '-' ) {
 100                 confess "[$command] $result";
 101         } elsif ( $type eq '+' ) {
 102                 return $result;
 103         } elsif ( $type eq '$' ) {
 104                 return $self->__read_bulk($result);
 105         } elsif ( $type eq '*' ) {
 106                 return $self->__read_multi_bulk($result);
 107         } elsif ( $type eq ':' ) {
 108                 return $result; # FIXME check if int?
 109         } else {
 110                 confess "unknown type: $type", $self->__read_line();
 111         }
 112 }
 113
 114
 115 ### Commands with extra logic
 116
 117 sub quit {
 118   my ($self) = @_;
 119
 120   $self->__send_command('QUIT');
 121
 122   close(delete $self->{sock}) || confess("Can't close socket: $!");
 123   return 1;
 124 }
 125
 126
 127 ### Socket operations
 128
 129 sub __send_command {
 130   my $self = shift;
 131   my $cmd  = uc(shift);
 132   my $enc  = $self->{encoding};
 133   my $deb  = $self->{debug};
 134
 135   warn "[SEND] $cmd ", Dumper([@_]) if $deb;
 136
 137   ## Encode command using multi-bulk format
 138   my $n_elems = scalar(@_) + 1;
 139   my $buf     = "\*$n_elems\r\n";
 140   for my $elem ($cmd, @_) {
 141     my $bin = $enc ? encode($enc, $elem) : $elem;
 142     $buf .= defined($bin) ? '$' . length($bin) . "\r\n$bin\r\n" : "\$-1\r\n";
 143   }
 144
 145   ## Send command, take care for partial writes
 146   warn "[SEND RAW] $buf" if $deb;
 147   my $sock = $self->{sock} || confess("Not connected to any server");
 148   while ($buf) {
 149     my $len = syswrite $sock, $buf, length $buf;
 150     confess("Could not write to Redis server: $!")
 151       unless $len;
 152     substr $buf, 0, $len, "";
 153   }
 154
 155   return;
 156 }
 157
 158 sub __read_bulk {
 159         my ($self,$len) = @_;
 160         return if $len < 0;
 161
 162         my $enc = $self->{encoding};
 163         my $v = '';
 164         if ( $len > 0 ) {
 165                 read($self->{sock}, $v, $len) || confess("Could not read from sock: $!");
 166                 $v = decode($enc, $v) if $enc;
 167         }
 168         my $crlf;
 169         read($self->{sock}, $crlf, 2); # skip cr/lf
 170
 171         warn "[PARSE] read_bulk ".Dumper($v) if $self->{debug};
 172         return $v;
 173 }
 174
 175 sub __read_multi_bulk {
 176         my ($self,$size) = @_;
 177         return if $size <= 0;
 178
 179         my $sock = $self->{sock};
 180         my $deb = $self->{debug};
 181         my $enc = $self->{encoding};
 182   my @list;
 183         while ($size--) {
 184                 my $v = $self->__read_bulk( substr(<$sock>,1,-2) );
 185                 $v = decode($enc, $v) if $enc;
 186                 warn "  [PARSE] read_multi_bulk ($size) ".Dumper($v) if $deb;
 187                 push @list, $v;
 188         }
 189
 190         warn "[PARSE] multi_bulk ".Dumper( \@list ) if $deb;
 191         return @list;
 192 }
 193
 194 1;
 195
 196 __END__
 197
 198 =head1 Connection Handling
 199
 200 =head2 quit
 201
 202   $r->quit;
 203
 204 =head2 ping
 205
 206   $r->ping || die "no server?";
 207
 208 =head1 Commands operating on string values
 209
 210 =head2 set
 211
 212   $r->set( foo => 'bar' );
 213
 214   $r->setnx( foo => 42 );
 215
 216 =head2 get
 217
 218   my $value = $r->get( 'foo' );
 219
 220 =head2 mget
 221
 222   my @values = $r->mget( 'foo', 'bar', 'baz' );
 223
 224 =head2 incr
 225
 226   $r->incr('counter');
 227
 228   $r->incrby('tripplets', 3);
 229
 230 =head2 decr
 231
 232   $r->decr('counter');
 233
 234   $r->decrby('tripplets', 3);
 235
 236 =head2 exists
 237
 238   $r->exists( 'key' ) && print "got key!";
 239
 240 =head2 del
 241
 242   $r->del( 'key' ) || warn "key doesn't exist";
 243
 244 =head2 type
 245
 246   $r->type( 'key' ); # = string
 247
 248 =head1 Commands operating on the key space
 249
 250 =head2 keys
 251
 252   my @keys = $r->keys( '*glob_pattern*' );
 253
 254 =head2 randomkey
 255
 256   my $key = $r->randomkey;
 257
 258 =head2 rename
 259
 260   my $ok = $r->rename( 'old-key', 'new-key', $new );
 261
 262 =head2 dbsize
 263
 264   my $nr_keys = $r->dbsize;
 265
 266 =head1 Commands operating on lists
 267
 268 See also L<Redis::List> for tie interface.
 269
 270 =head2 rpush
 271
 272   $r->rpush( $key, $value );
 273
 274 =head2 lpush
 275
 276   $r->lpush( $key, $value );
 277
 278 =head2 llen
 279
 280   $r->llen( $key );
 281
 282 =head2 lrange
 283
 284   my @list = $r->lrange( $key, $start, $end );
 285
 286 =head2 ltrim
 287
 288   my $ok = $r->ltrim( $key, $start, $end );
 289
 290 =head2 lindex
 291
 292   $r->lindex( $key, $index );
 293
 294 =head2 lset
 295
 296   $r->lset( $key, $index, $value );
 297
 298 =head2 lrem
 299
 300   my $modified_count = $r->lrem( $key, $count, $value );
 301
 302 =head2 lpop
 303
 304   my $value = $r->lpop( $key );
 305
 306 =head2 rpop
 307
 308   my $value = $r->rpop( $key );
 309
 310 =head1 Commands operating on sets
 311
 312 =head2 sadd
 313
 314   $r->sadd( $key, $member );
 315
 316 =head2 srem
 317
 318   $r->srem( $key, $member );
 319
 320 =head2 scard
 321
 322   my $elements = $r->scard( $key );
 323
 324 =head2 sismember
 325
 326   $r->sismember( $key, $member );
 327
 328 =head2 sinter
 329
 330   $r->sinter( $key1, $key2, ... );
 331
 332 =head2 sinterstore
 333
 334   my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
 335
 336 =head1 Multiple databases handling commands
 337
 338 =head2 select
 339
 340   $r->select( $dbindex ); # 0 for new clients
 341
 342 =head2 move
 343
 344   $r->move( $key, $dbindex );
 345
 346 =head2 flushdb
 347
 348   $r->flushdb;
 349
 350 =head2 flushall
 351
 352   $r->flushall;
 353
 354 =head1 Sorting
 355
 356 =head2 sort
 357
 358   $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
 359
 360 =head1 Persistence control commands
 361
 362 =head2 save
 363
 364   $r->save;
 365
 366 =head2 bgsave
 367
 368   $r->bgsave;
 369
 370 =head2 lastsave
 371
 372   $r->lastsave;
 373
 374 =head2 shutdown
 375
 376   $r->shutdown;
 377
 378 =head1 Remote server control commands
 379
 380 =head2 info
 381
 382   my $info_hash = $r->info;
 383
 384 =head1 ENCODING
 385
 386 Since Redis knows nothing about encoding, we are forcing utf-8 flag on all data received from Redis.
 387 This change is introduced in 1.2001 version.
 388
 389 This allows us to round-trip utf-8 encoded characters correctly, but might be problem if you push
 390 binary junk into Redis and expect to get it back without utf-8 flag turned on.
 391
 392 =head1 AUTHOR
 393
 394 Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
 395
 396 =head1 BUGS
 397
 398 Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
 399 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>.  I will be notified, and then you'll
 400 automatically be notified of progress on your bug as I make changes.
 401
 402
 403
 404
 405 =head1 SUPPORT
 406
 407 You can find documentation for this module with the perldoc command.
 408
 409     perldoc Redis
 410         perldoc Redis::List
 411         perldoc Redis::Hash
 412
 413
 414 You can also look for information at:
 415
 416 =over 4
 417
 418 =item * RT: CPAN's request tracker
 419
 420 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
 421
 422 =item * AnnoCPAN: Annotated CPAN documentation
 423
 424 L<http://annocpan.org/dist/Redis>
 425
 426 =item * CPAN Ratings
 427
 428 L<http://cpanratings.perl.org/d/Redis>
 429
 430 =item * Search CPAN
 431
 432 L<http://search.cpan.org/dist/Redis>
 433
 434 =back
 435
 436
 437 =head1 ACKNOWLEDGEMENTS
 438
 439
 440 =head1 COPYRIGHT & LICENSE
 441
 442 Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
 443
 444 This program is free software; you can redistribute it and/or modify it
 445 under the same terms as Perl itself.
 446
 447
 448 =cut
 449
 450 1; # End of Redis