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