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