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