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