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