lib/Redis.pm

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