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