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