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
  71 sub AUTOLOAD {
  72   my $self = shift;
  73   my $sock = $self->{sock} || confess("Not connected to any server");
  74   my $enc  = $self->{encoding};
  75   my $deb  = $self->{debug};
  76
  77   my $command = $AUTOLOAD;
  78   $command =~ s/.*://;
  79   $self->__is_valid_command($command);
  80
  81   $self->__send_command($command, @_);
  82
  83   return $self->__read_response($command);
  84 }
  85
  86
  87 ### Commands with extra logic
  88 sub quit {
  89   my ($self) = @_;
  90
  91   $self->__send_command('QUIT');
  92
  93   close(delete $self->{sock}) || confess("Can't close socket: $!");
  94   delete $self->{rbuf};
  95
  96   return 1;
  97 }
  98
  99 sub info {
 100   my ($self) = @_;
 101   $self->__is_valid_command('INFO');
 102
 103   $self->__send_command('INFO');
 104
 105   my $info = $self->__read_response('INFO');
 106
 107   return {map { split(/:/, $_, 2) } split(/\r\n/, $info)};
 108 }
 109
 110 sub keys {
 111   my $self = shift;
 112   $self->__is_valid_command('KEYS');
 113
 114   $self->__send_command('KEYS', @_);
 115
 116   my @keys = $self->__read_response('INFO', \my $type);
 117   return @keys if $type eq '*';
 118
 119   ## Support redis <= 1.2.6
 120   return split(/\s/, $keys[0]) if $keys[0];
 121   return;
 122 }
 123
 124
 125 ### Mode validation
 126 sub __is_valid_command {
 127   my ($self, $cmd) = @_;
 128
 129   return unless $self->{is_subscriber};
 130   return if $cmd =~ /^P?(UN)?SUBSCRIBE$/;
 131   confess("Cannot use command '$cmd' while in SUBSCRIBE mode, ");
 132 }
 133
 134
 135 ### Socket operations
 136 sub __send_command {
 137   my $self = shift;
 138   my $cmd  = uc(shift);
 139   my $enc  = $self->{encoding};
 140   my $deb  = $self->{debug};
 141
 142   warn "[SEND] $cmd ", Dumper([@_]) if $deb;
 143
 144   ## Encode command using multi-bulk format
 145   my $n_elems = scalar(@_) + 1;
 146   my $buf     = "\*$n_elems\r\n";
 147   for my $elem ($cmd, @_) {
 148     my $bin = $enc ? encode($enc, $elem) : $elem;
 149     $buf .= defined($bin) ? '$' . length($bin) . "\r\n$bin\r\n" : "\$-1\r\n";
 150   }
 151
 152   ## Send command, take care for partial writes
 153   warn "[SEND RAW] $buf" if $deb;
 154   my $sock = $self->{sock} || confess("Not connected to any server");
 155   while ($buf) {
 156     my $len = syswrite $sock, $buf, length $buf;
 157     confess("Could not write to Redis server: $!")
 158       unless $len;
 159     substr $buf, 0, $len, "";
 160   }
 161
 162   return;
 163 }
 164
 165 sub __read_response {
 166   my ($self, $command, $type_r) = @_;
 167
 168   my ($type, $result) = $self->__read_sock;
 169   $$type_r = $type if $type_r;
 170
 171   if ($type eq '-') {
 172     confess "[$command] $result, ";
 173   }
 174   elsif ($type eq '+') {
 175     return $result;
 176   }
 177   elsif ($type eq '$') {
 178     return if $result < 0;
 179     return $self->__read_sock($result);
 180   }
 181   elsif ($type eq '*') {
 182     my @list;
 183     while ($result--) {
 184       push @list, $self->__read_response($command);
 185     }
 186     return @list;
 187   }
 188   elsif ($type eq ':') {
 189     return $result;
 190   }
 191   else {
 192     confess "unknown answer type: $type ($result), ";
 193   }
 194 }
 195
 196 sub __read_sock {
 197   my ($self, $len) = @_;
 198   my $sock = $self->{sock} || confess("Not connected to any server");
 199   my $enc  = $self->{encoding};
 200   my $deb  = $self->{debug};
 201   my $rbuf = \($self->{rbuf});
 202
 203   my ($data, $type) = ('', '');
 204   my $read_size = defined $len ? $len + 2 : 8192;
 205   while (1) {
 206     ## Read NN bytes, strip \r\n at the end
 207     if (defined $len) {
 208       if (length($$rbuf) >= $len + 2) {
 209         $data = substr(substr($$rbuf, 0, $len + 2, ''), 0, -2);
 210         last;
 211       }
 212     }
 213     ## No len, means line more, read until \r\n
 214     elsif ($$rbuf =~ s/^(.)([^\015\012]*)\015\012//) {
 215       ($type, $data) = ($1, $2);
 216       last;
 217     }
 218
 219     my $bytes = sysread $sock, $$rbuf, $read_size, length $$rbuf;
 220     confess("Error while reading from Redis server: $!")
 221       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