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