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