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