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