lib/Redis.pm

   1 package Redis;
   2
   3 use warnings;
   4 use strict;
   5
   6 use IO::Socket::INET;
   7 use Fcntl qw( O_NONBLOCK F_SETFL );
   8 use Data::Dumper;
   9 use Carp qw/confess/;
  10 use Encode;
  11
  12 =head1 NAME
  13
  14 Redis - perl binding for Redis database
  15
  16 =cut
  17
  18 our $VERSION = '1.2001';
  19
  20
  21 =head1 DESCRIPTION
  22
  23 Pure perl bindings for L<http://code.google.com/p/redis/>
  24
  25 This version supports protocol 1.2 or later of Redis available at
  26
  27 L<git://github.com/antirez/redis>
  28
  29 This documentation
  30 lists commands which are exercised in test suite, but
  31 additinal commands will work correctly since protocol
  32 specifies enough information to support almost all commands
  33 with same peace of code with a little help of C<AUTOLOAD>.
  34
  35 =head1 FUNCTIONS
  36
  37 =head2 new
  38
  39   my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
  40
  41   my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
  42
  43 =cut
  44
  45 sub new {
  46   my $class = shift;
  47   my $self  = {@_};
  48
  49   $self->{debug} ||= $ENV{REDIS_DEBUG};
  50   $self->{encoding} ||= 'utf8';    ## default to lax utf8
  51
  52   $self->{server} ||= $ENV{REDIS_SERVER} || '127.0.0.1:6379';
  53   $self->{sock} = IO::Socket::INET->new(
  54     PeerAddr => $self->{server},
  55     Proto    => 'tcp',
  56   ) || confess("Could not connect to Redis server at $self->{server}: $!");
  57
  58   $self->{read_size} = 8192;
  59   $self->{rbuf}      = '';
  60
  61   $self->{is_subscriber} = 0;
  62
  63   return bless($self, $class);
  64 }
  65
  66
  67 ### we don't want DESTROY to fallback into AUTOLOAD
  68 sub DESTROY { }
  69
  70
  71 ### Deal with common, general case, Redis commands
  72 our $AUTOLOAD;
  73
  74 sub AUTOLOAD {
  75   my $self = shift;
  76   my $sock = $self->{sock} || confess("Not connected to any server");
  77   my $enc  = $self->{encoding};
  78   my $deb  = $self->{debug};
  79
  80   my $command = $AUTOLOAD;
  81   $command =~ s/.*://;
  82   $self->__is_valid_command($command);
  83
  84   $self->__send_command($command, @_);
  85
  86   return $self->__read_response($command);
  87 }
  88
  89
  90 ### Commands with extra logic
  91 sub quit {
  92   my ($self) = @_;
  93
  94   $self->__send_command('QUIT');
  95
  96   delete $self->{rbuf};
  97   close(delete $self->{sock}) || confess("Can't close socket: $!");
  98
  99   return 1;
 100 }
 101
 102 sub info {
 103   my ($self) = @_;
 104   $self->__is_valid_command('INFO');
 105
 106   $self->__send_command('INFO');
 107
 108   my $info = $self->__read_response('INFO');
 109
 110   return {map { split(/:/, $_, 2) } split(/\r\n/, $info)};
 111 }
 112
 113 sub keys {
 114   my $self = shift;
 115   $self->__is_valid_command('KEYS');
 116
 117   $self->__send_command('KEYS', @_);
 118
 119   my @keys = $self->__read_response('INFO', \my $type);
 120   return @keys if $type eq '*';
 121
 122   ## Support redis <= 1.2.6
 123   return split(/\s/, $keys[0]) if $keys[0];
 124   return;
 125 }
 126
 127
 128 ### Mode validation
 129 sub __is_valid_command {
 130   my ($self, $cmd) = @_;
 131
 132   return unless $self->{is_subscriber};
 133   return if $cmd =~ /^P?(UN)?SUBSCRIBE$/i;
 134   confess("Cannot use command '$cmd' while in SUBSCRIBE mode, ");
 135 }
 136
 137
 138 ### Socket operations
 139 sub __send_command {
 140   my $self = shift;
 141   my $cmd  = uc(shift);
 142   my $enc  = $self->{encoding};
 143   my $deb  = $self->{debug};
 144
 145   warn "[SEND] $cmd ", Dumper([@_]) if $deb;
 146
 147   ## Encode command using multi-bulk format
 148   my $n_elems = scalar(@_) + 1;
 149   my $buf     = "\*$n_elems\r\n";
 150   for my $elem ($cmd, @_) {
 151     my $bin = $enc ? encode($enc, $elem) : $elem;
 152     $buf .= defined($bin) ? '$' . length($bin) . "\r\n$bin\r\n" : "\$-1\r\n";
 153   }
 154
 155   ## Send command, take care for partial writes
 156   warn "[SEND RAW] $buf" if $deb;
 157   my $sock = $self->{sock} || confess("Not connected to any server");
 158   while ($buf) {
 159     my $len = syswrite $sock, $buf, length $buf;
 160     confess("Could not write to Redis server: $!")
 161       unless $len;
 162     substr $buf, 0, $len, "";
 163   }
 164
 165   return;
 166 }
 167
 168 sub __read_response {
 169   my ($self, $command, $type_r) = @_;
 170
 171   my ($type, $result) = $self->__read_sock;
 172   $$type_r = $type if $type_r;
 173
 174   if ($type eq '-') {
 175     confess "[$command] $result, ";
 176   }
 177   elsif ($type eq '+') {
 178     return $result;
 179   }
 180   elsif ($type eq '$') {
 181     return if $result < 0;
 182     return $self->__read_sock($result);
 183   }
 184   elsif ($type eq '*') {
 185     my @list;
 186     while ($result--) {
 187       push @list, $self->__read_response($command);
 188     }
 189     return @list;
 190   }
 191   elsif ($type eq ':') {
 192     return $result;
 193   }
 194   else {
 195     confess "unknown answer type: $type ($result), ";
 196   }
 197 }
 198
 199 sub __read_sock {
 200   my ($self, $len) = @_;
 201   my $sock = $self->{sock} || confess("Not connected to any server");
 202   my $enc  = $self->{encoding};
 203   my $deb  = $self->{debug};
 204   my $rbuf = \($self->{rbuf});
 205
 206   my ($data, $type) = ('', '');
 207   my $read_size = $self->{read_size};
 208   $read_size = $len + 2 if defined $len && $len + 2 > $read_size;
 209
 210   while (1) {
 211     ## Read NN bytes, strip \r\n at the end
 212     if (defined $len) {
 213       if (length($$rbuf) >= $len + 2) {
 214         $data = substr(substr($$rbuf, 0, $len + 2, ''), 0, -2);
 215         last;
 216       }
 217     }
 218     ## No len, means line more, read until \r\n
 219     elsif ($$rbuf =~ s/^(.)([^\015\012]*)\015\012//) {
 220       ($type, $data) = ($1, $2);
 221       last;
 222     }
 223
 224     my $bytes = sysread $sock, $$rbuf, $read_size, length $$rbuf;
 225     confess("Error while reading from Redis server: $!")
 226       unless defined $bytes;
 227     confess("Redis server closed connection") unless $bytes;
 228   }
 229
 230   $data = decode($enc, $data) if $enc;
 231   warn "[RECV] '$type$data'" if $self->{debug};
 232
 233   return ($type, $data) if $type;
 234   return $data;
 235 }
 236
 237 sub __can_read_sock {
 238   my ($self) = @_;
 239   my $sock   = $self->{sock};
 240   my $rbuf   = \($self->{rbuf});
 241
 242   return 1 if $$rbuf;
 243   __fh_nonblocking($sock, 1);
 244   my $bytes = sysread $sock, $$rbuf, $self->{read_size}, length $$rbuf;
 245   __fh_nonblocking($sock, 0);
 246   return 1 if $bytes;
 247   return 0;
 248 }
 249
 250
 251 ### Copied from AnyEvent::Util
 252 BEGIN {
 253   *__fh_nonblocking = ($^O eq 'MSWin32')
 254     ? sub($$) { ioctl $_[0], 0x8004667e, pack "L", $_[1]; }    # FIONBIO
 255     : sub($$) { fcntl $_[0], F_SETFL, $_[1] ? O_NONBLOCK : 0; };
 256 }
 257
 258
 259 1;
 260
 261 __END__
 262
 263 =head1 Connection Handling
 264
 265 =head2 quit
 266
 267   $r->quit;
 268
 269 =head2 ping
 270
 271   $r->ping || die "no server?";
 272
 273 =head1 Commands operating on string values
 274
 275 =head2 set
 276
 277   $r->set( foo => 'bar' );
 278
 279   $r->setnx( foo => 42 );
 280
 281 =head2 get
 282
 283   my $value = $r->get( 'foo' );
 284
 285 =head2 mget
 286
 287   my @values = $r->mget( 'foo', 'bar', 'baz' );
 288
 289 =head2 incr
 290
 291   $r->incr('counter');
 292
 293   $r->incrby('tripplets', 3);
 294
 295 =head2 decr
 296
 297   $r->decr('counter');
 298
 299   $r->decrby('tripplets', 3);
 300
 301 =head2 exists
 302
 303   $r->exists( 'key' ) && print "got key!";
 304
 305 =head2 del
 306
 307   $r->del( 'key' ) || warn "key doesn't exist";
 308
 309 =head2 type
 310
 311   $r->type( 'key' ); # = string
 312
 313 =head1 Commands operating on the key space
 314
 315 =head2 keys
 316
 317   my @keys = $r->keys( '*glob_pattern*' );
 318
 319 =head2 randomkey
 320
 321   my $key = $r->randomkey;
 322
 323 =head2 rename
 324
 325   my $ok = $r->rename( 'old-key', 'new-key', $new );
 326
 327 =head2 dbsize
 328
 329   my $nr_keys = $r->dbsize;
 330
 331 =head1 Commands operating on lists
 332
 333 See also L<Redis::List> for tie interface.
 334
 335 =head2 rpush
 336
 337   $r->rpush( $key, $value );
 338
 339 =head2 lpush
 340
 341   $r->lpush( $key, $value );
 342
 343 =head2 llen
 344
 345   $r->llen( $key );
 346
 347 =head2 lrange
 348
 349   my @list = $r->lrange( $key, $start, $end );
 350
 351 =head2 ltrim
 352
 353   my $ok = $r->ltrim( $key, $start, $end );
 354
 355 =head2 lindex
 356
 357   $r->lindex( $key, $index );
 358
 359 =head2 lset
 360
 361   $r->lset( $key, $index, $value );
 362
 363 =head2 lrem
 364
 365   my $modified_count = $r->lrem( $key, $count, $value );
 366
 367 =head2 lpop
 368
 369   my $value = $r->lpop( $key );
 370
 371 =head2 rpop
 372
 373   my $value = $r->rpop( $key );
 374
 375 =head1 Commands operating on sets
 376
 377 =head2 sadd
 378
 379   $r->sadd( $key, $member );
 380
 381 =head2 srem
 382
 383   $r->srem( $key, $member );
 384
 385 =head2 scard
 386
 387   my $elements = $r->scard( $key );
 388
 389 =head2 sismember
 390
 391   $r->sismember( $key, $member );
 392
 393 =head2 sinter
 394
 395   $r->sinter( $key1, $key2, ... );
 396
 397 =head2 sinterstore
 398
 399   my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
 400
 401 =head1 Multiple databases handling commands
 402
 403 =head2 select
 404
 405   $r->select( $dbindex ); # 0 for new clients
 406
 407 =head2 move
 408
 409   $r->move( $key, $dbindex );
 410
 411 =head2 flushdb
 412
 413   $r->flushdb;
 414
 415 =head2 flushall
 416
 417   $r->flushall;
 418
 419 =head1 Sorting
 420
 421 =head2 sort
 422
 423   $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
 424
 425 =head1 Persistence control commands
 426
 427 =head2 save
 428
 429   $r->save;
 430
 431 =head2 bgsave
 432
 433   $r->bgsave;
 434
 435 =head2 lastsave
 436
 437   $r->lastsave;
 438
 439 =head2 shutdown
 440
 441   $r->shutdown;
 442
 443 =head1 Remote server control commands
 444
 445 =head2 info
 446
 447   my $info_hash = $r->info;
 448
 449 =head1 ENCODING
 450
 451 Since Redis knows nothing about encoding, we are forcing utf-8 flag on all data received from Redis.
 452 This change is introduced in 1.2001 version.
 453
 454 This allows us to round-trip utf-8 encoded characters correctly, but might be problem if you push
 455 binary junk into Redis and expect to get it back without utf-8 flag turned on.
 456
 457 =head1 AUTHOR
 458
 459 Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
 460
 461 =head1 BUGS
 462
 463 Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
 464 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>.  I will be notified, and then you'll
 465 automatically be notified of progress on your bug as I make changes.
 466
 467
 468
 469
 470 =head1 SUPPORT
 471
 472 You can find documentation for this module with the perldoc command.
 473
 474     perldoc Redis
 475         perldoc Redis::List
 476         perldoc Redis::Hash
 477
 478
 479 You can also look for information at:
 480
 481 =over 4
 482
 483 =item * RT: CPAN's request tracker
 484
 485 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
 486
 487 =item * AnnoCPAN: Annotated CPAN documentation
 488
 489 L<http://annocpan.org/dist/Redis>
 490
 491 =item * CPAN Ratings
 492
 493 L<http://cpanratings.perl.org/d/Redis>
 494
 495 =item * Search CPAN
 496
 497 L<http://search.cpan.org/dist/Redis>
 498
 499 =back
 500
 501
 502 =head1 ACKNOWLEDGEMENTS
 503
 504
 505 =head1 COPYRIGHT & LICENSE
 506
 507 Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
 508
 509 This program is free software; you can redistribute it and/or modify it
 510 under the same terms as Perl itself.
 511
 512
 513 =cut
 514
 515 1; # End of Redis