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> || die "can't read socket: $!";
 121         Encode::_utf8_on($result);
 122         warn "<< $result" if $self->{debug};
 123         my $type = substr($result,0,1);
 124         $result = substr($result,1,-2);
 125
 126         if ( $command eq 'info' ) {
 127                 my $hash;
 128                 foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
 129                         my ($n,$v) = split(/:/, $l, 2);
 130                         $hash->{$n} = $v;
 131                 }
 132                 return $hash;
 133         } elsif ( $command eq 'keys' ) {
 134                 my $keys = $self->__read_bulk($result);
 135                 return split(/\s/, $keys) if $keys;
 136                 return;
 137         }
 138
 139         if ( $type eq '-' ) {
 140                 confess "[$command] $result";
 141         } elsif ( $type eq '+' ) {
 142                 return $result;
 143         } elsif ( $type eq '$' ) {
 144                 return $self->__read_bulk($result);
 145         } elsif ( $type eq '*' ) {
 146                 return $self->__read_multi_bulk($result);
 147         } elsif ( $type eq ':' ) {
 148                 return $result; # FIXME check if int?
 149         } else {
 150                 confess "unknown type: $type", $self->__read_line();
 151         }
 152 }
 153
 154 sub __read_bulk {
 155         my ($self,$len) = @_;
 156         return if $len < 0;
 157
 158         my $v;
 159         if ( $len > 0 ) {
 160                 read($self->{sock}, $v, $len) || die $!;
 161                 Encode::_utf8_on($v);
 162                 warn "<< ",Dumper($v),$/ if $self->{debug};
 163         }
 164         my $crlf;
 165         read($self->{sock}, $crlf, 2); # skip cr/lf
 166         return $v;
 167 }
 168
 169 sub __read_multi_bulk {
 170         my ($self,$size) = @_;
 171         return if $size < 0;
 172         my $sock = $self->{sock};
 173
 174         $size--;
 175
 176         my @list = ( 0 .. $size );
 177         foreach ( 0 .. $size ) {
 178                 $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
 179         }
 180
 181         warn "## list = ", Dumper( @list ) if $self->{debug};
 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