/[Redis.pre-github]/lib/Redis.pm

This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!

Diff of /lib/Redis.pm

Parent Directory | Revision Log | View Patch Patch

-revision 9 by dpavlin,
Sat Mar 21 22:54:10 2009 UTC
+revision 70 by dpavlin,
Wed Mar 17 20:26:07 2010 UTC
 Line 4 
 use warnings;
  use strict;
  use IO::Socket::INET;
- use Data::Dump qw/dump/;
+ use Data::Dumper;
  use Carp qw/confess/;
+ use Encode;
  =head1 NAME
- Redis - The great new Redis!
+ Redis - perl binding for Redis database
  =cut
- our $VERSION = '0.01';
+ our $VERSION = '1.2001';
- =head1 SYNOPSIS
+ =head1 DESCRIPTION
  Pure perl bindings for L<http://code.google.com/p/redis/>
-     use Redis;
+ This version supports protocol 1.2 or later of Redis available at
-     my $r = Redis->new();
+ L<git://github.com/antirez/redis>
+ This documentation
+ lists commands which are exercised in test suite, but
+ additinal commands will work correctly since protocol
+ specifies enough information to support almost all commands
+ with same peace of code with a little help of C<AUTOLOAD>.
  =head1 FUNCTIONS
  =head2 new
- =cut
+   my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
- our $sock;
+   my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
- my $server = '127.0.0.1:6379';
+ =cut
  sub new {
          my $class = shift;
-         my $self = {};
+         my $self = {@_};
-         bless($self, $class);
+         $self->{debug} ||= $ENV{REDIS_DEBUG};
-         warn "# opening socket to $server";
-         $sock ||= IO::Socket::INET->new(
+         $self->{sock} = IO::Socket::INET->new(
-                 PeerAddr => $server,
+                 PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
                  Proto => 'tcp',
          ) || die $!;
+         bless($self, $class);
          $self;
  }
- =head1 Connection Handling
+ my $bulk_command = {
+         set => 1,       setnx => 1,
+         rpush => 1,     lpush => 1,
+         lset => 1,      lrem => 1,
+         sadd => 1,      srem => 1,
+         sismember => 1,
+         echo => 1,
+         getset => 1,
+         smove => 1,
+         zadd => 1,
+         zrem => 1,
+         zscore => 1,
+         zincrby => 1,
+         append => 1,
+ };
- =head2 quit
+ # we don't want DESTROY to fallback into AUTOLOAD
+ sub DESTROY {}
-   $r->quit;
+ our $AUTOLOAD;
+ sub AUTOLOAD {
+         my $self = shift;
- =cut
+         use bytes;
- sub quit {
+         my $sock = $self->{sock} || die "no server connected";
-         my $self = shift;
-         close( $sock ) || warn $!;
+         my $command = $AUTOLOAD;
+         $command =~ s/.*://;
+         warn "## $command ",Dumper(@_) if $self->{debug};
+         my $send;
+         if ( defined $bulk_command->{$command} ) {
+                 my $value = pop;
+                 $value = '' if ! defined $value;
+                 $send
+                         = uc($command)
+                         . ' '
+                         . join(' ', @_)
+                         . ' '
+                         . length( $value )
+                         . "\r\n$value\r\n"
+                         ;
+         } else {
+                 $send
+                         = uc($command)
+                         . ' '
+                         . join(' ', @_)
+                         . "\r\n"
+                         ;
+         }
+         warn ">> $send" if $self->{debug};
+         print $sock $send;
+         if ( $command eq 'quit' ) {
+                 close( $sock ) || die "can't close socket: $!";
+                 return 1;
+         }
+         my $result = <$sock> || die "can't read socket: $!";
+         Encode::_utf8_on($result);
+         warn "<< $result" if $self->{debug};
+         my $type = substr($result,0,1);
+         $result = substr($result,1,-2);
+         if ( $command eq 'info' ) {
+                 my $hash;
+                 foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
+                         my ($n,$v) = split(/:/, $l, 2);
+                         $hash->{$n} = $v;
+                 }
+                 return $hash;
+         } elsif ( $command eq 'keys' ) {
+                 my $keys = $self->__read_bulk($result);
+                 return split(/\s/, $keys) if $keys;
+                 return;
+         }
+         if ( $type eq '-' ) {
+                 confess "[$command] $result";
+         } elsif ( $type eq '+' ) {
+                 return $result;
+         } elsif ( $type eq '$' ) {
+                 return $self->__read_bulk($result);
+         } elsif ( $type eq '*' ) {
+                 return $self->__read_multi_bulk($result);
+         } elsif ( $type eq ':' ) {
+                 return $result; # FIXME check if int?
+         } else {
+                 confess "unknown type: $type", $self->__read_line();
+         }
  }
- =head2 ping
+ sub __read_bulk {
+         my ($self,$len) = @_;
+         return undef if $len < 0;
-   $r->ping || die "no server?";
+         my $v;
+         if ( $len > 0 ) {
+                 read($self->{sock}, $v, $len) || die $!;
+                 Encode::_utf8_on($v);
+                 warn "<< ",Dumper($v),$/ if $self->{debug};
+         }
+         my $crlf;
+         read($self->{sock}, $crlf, 2); # skip cr/lf
+         return $v;
+ }
- =cut
+ sub __read_multi_bulk {
+         my ($self,$size) = @_;
+         return undef if $size < 0;
+         my $sock = $self->{sock};
+         $size--;
+         my @list = ( 0 .. $size );
+         foreach ( 0 .. $size ) {
+                 $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
+         }
- sub ping {
+         warn "## list = ", Dumper( @list ) if $self->{debug};
-         print $sock "PING\r\n";
+         return @list;
-         my $pong = <$sock>;
-         die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
  }
+;
+ __END__
+ =head1 Connection Handling
+ =head2 quit
+   $r->quit;
+ =head2 ping
+   $r->ping || die "no server?";
  =head1 Commands operating on string values
  =head2 set
-   $r->set( foo => 'bar', $new );
+   $r->set( foo => 'bar' );
- =cut
- sub set {
+   $r->setnx( foo => 42 );
-         my ( $self, $k, $v, $new ) = @_;
-         print $sock ( $new ? "SETNX" : "SET" ) . " $k " . length($v) . "\r\n$v\r\n";
-         my $ok = <$sock>;
-         confess dump($ok) unless $ok eq "+OK\r\n";
- }
  =head2 get
    my $value = $r->get( 'foo' );
- =cut
+ =head2 mget
- sub get {
+   my @values = $r->mget( 'foo', 'bar', 'baz' );
-         my ( $self, $k ) = @_;
-         print $sock "GET $k\r\n";
-         my $len = <$sock>;
- #       warn "# len: ",dump($len);
-         return undef if $len eq "nil\r\n";
-         my $v;
-         read($sock, $v, $len) || die $!;
- #       warn "# v: ",dump($v);
-         my $crlf;
-         read($sock, $crlf, 2); # skip cr/lf
-         return $v;
- }
  =head2 incr
    $r->incr('counter');
-   $r->incr('tripplets', 3);
- =cut
+   $r->incrby('tripplets', 3);
- sub incr {
-         my ( $self, $key, $value ) = @_;
-         if ( defined $value ) {
-                 print $sock "INCRBY $key $value\r\n";
-         } else {
-                 print $sock "INCR $key\r\n";
-         }
-         my $count = <$sock>;
-         warn "# $key = $count";
-         return $count;
- }
  =head2 decr
    $r->decr('counter');
-   $r->decr('tripplets', 3);
- =cut
+   $r->decrby('tripplets', 3);
- sub decr {
-         my ( $self, $key, $value ) = @_;
-         if ( defined $value ) {
-                 print $sock "DECRBY $key $value\r\n";
-         } else {
-                 print $sock "DECR $key\r\n";
-         }
-         my $count = <$sock>;
-         warn "# $key = $count";
-         return $count;
- }
  =head2 exists
    $r->exists( 'key' ) && print "got key!";
- =cut
+ =head2 del
- sub exists {
+   $r->del( 'key' ) || warn "key doesn't exist";
-         my ( $self, $key ) = @_;
-         print $sock "EXISTS $key\r\n";
+ =head2 type
-         my $found = <$sock>;
-         $found =~ s{\r\n$}{};
+   $r->type( 'key' ); # = string
-         warn "# exists $key = $found";
-         return $found;
+ =head1 Commands operating on the key space
- }
+ =head2 keys
+   my @keys = $r->keys( '*glob_pattern*' );
+ =head2 randomkey
+   my $key = $r->randomkey;
+ =head2 rename
+   my $ok = $r->rename( 'old-key', 'new-key', $new );
+ =head2 dbsize
+   my $nr_keys = $r->dbsize;
+ =head1 Commands operating on lists
+ See also L<Redis::List> for tie interface.
+ =head2 rpush
+   $r->rpush( $key, $value );
+ =head2 lpush
+   $r->lpush( $key, $value );
+ =head2 llen
+   $r->llen( $key );
+ =head2 lrange
+   my @list = $r->lrange( $key, $start, $end );
+ =head2 ltrim
+   my $ok = $r->ltrim( $key, $start, $end );
+ =head2 lindex
+   $r->lindex( $key, $index );
+ =head2 lset
+   $r->lset( $key, $index, $value );
+ =head2 lrem
+   my $modified_count = $r->lrem( $key, $count, $value );
+ =head2 lpop
+   my $value = $r->lpop( $key );
+ =head2 rpop
+   my $value = $r->rpop( $key );
+ =head1 Commands operating on sets
+ =head2 sadd
+   $r->sadd( $key, $member );
+ =head2 srem
+   $r->srem( $key, $member );
+ =head2 scard
+   my $elements = $r->scard( $key );
+ =head2 sismember
+   $r->sismember( $key, $member );
+ =head2 sinter
+   $r->sinter( $key1, $key2, ... );
+ =head2 sinterstore
+   my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
+ =head1 Multiple databases handling commands
+ =head2 select
+   $r->select( $dbindex ); # 0 for new clients
+ =head2 move
+   $r->move( $key, $dbindex );
+ =head2 flushdb
+   $r->flushdb;
+ =head2 flushall
+   $r->flushall;
+ =head1 Sorting
+ =head2 sort
+   $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
+ =head1 Persistence control commands
+ =head2 save
+   $r->save;
+ =head2 bgsave
+   $r->bgsave;
+ =head2 lastsave
+   $r->lastsave;
+ =head2 shutdown
+   $r->shutdown;
+ =head1 Remote server control commands
+ =head2 info
+   my $info_hash = $r->info;
  =head1 AUTHOR
-Line 183 
 automatically be notified of progress on
+Line 390 
 automatically be notified of progress on
  You can find documentation for this module with the perldoc command.
      perldoc Redis
+         perldoc Redis::List
+         perldoc Redis::Hash
  You can also look for information at:
-Line 213 
 L<http://search.cpan.org/dist/Redis>
+Line 422 
 L<http://search.cpan.org/dist/Redis>
  =head1 COPYRIGHT & LICENSE
- Copyright 2009 Dobrica Pavlinusic, all rights reserved.
+ Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.

 Legend:



Removed from v.9
 


changed lines


 
Added in v.70
 Legend:



Removed from v.9
 


changed lines


 
Added in v.70
-Removed from v.9
+Added in v.70

	ViewVC Help
Powered by ViewVC 1.1.26