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