/[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!
ViewVC logotype

Diff of /lib/Redis.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 47 by dpavlin, Mon Mar 23 11:30:40 2009 UTC revision 63 by dpavlin, Mon Sep 14 11:37:25 2009 UTC
# Line 4  use warnings; Line 4  use warnings;
4  use strict;  use strict;
5    
6  use IO::Socket::INET;  use IO::Socket::INET;
7  use Data::Dump qw/dump/;  use Data::Dumper;
8  use Carp qw/confess/;  use Carp qw/confess/;
9    
10  =head1 NAME  =head1 NAME
# Line 13  Redis - perl binding for Redis database Line 13  Redis - perl binding for Redis database
13    
14  =cut  =cut
15    
16  our $VERSION = '0.01';  our $VERSION = '0.0801';
17    
18    
19  =head1 SYNOPSIS  =head1 DESCRIPTION
20    
21  Pure perl bindings for L<http://code.google.com/p/redis/>  Pure perl bindings for L<http://code.google.com/p/redis/>
22    
23  This version support git version of Redis available at  This version support git version 0.08 or later of Redis available at
 L<git://github.com/antirez/redis>  
24    
25      use Redis;  L<git://github.com/antirez/redis>
26    
27      my $r = Redis->new();  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  =head1 FUNCTIONS
34    
35  =head2 new  =head2 new
36    
37  =cut    my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
38    
39  our $debug = $ENV{REDIS} || 0;    my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
40    
41  our $sock;  =cut
 my $server = '127.0.0.1:6379';  
42    
43  sub new {  sub new {
44          my $class = shift;          my $class = shift;
45          my $self = {};          my $self = {@_};
46          bless($self, $class);          $self->{debug} ||= $ENV{REDIS_DEBUG};
   
         warn "# opening socket to $server";  
47    
48          $sock ||= IO::Socket::INET->new(          $self->{sock} = IO::Socket::INET->new(
49                  PeerAddr => $server,                  PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
50                  Proto => 'tcp',                  Proto => 'tcp',
51          ) || die $!;          ) || die $!;
52    
53            bless($self, $class);
54          $self;          $self;
55  }  }
56    
57  sub __sock_result {  my $bulk_command = {
58          my $result = <$sock>;          set => 1,       setnx => 1,
59          warn "## result: ",dump( $result ) if $debug;          rpush => 1,     lpush => 1,
60          $result =~ s{\r\n$}{} || warn "can't find cr/lf";          lset => 1,      lrem => 1,
61          return $result;          sadd => 1,      srem => 1,
62            sismember => 1,
63            echo => 1,
64    };
65    
66    # we don't want DESTROY to fallback into AUTOLOAD
67    sub DESTROY {}
68    
69    our $AUTOLOAD;
70    sub AUTOLOAD {
71            my $self = shift;
72    
73            my $sock = $self->{sock} || die "no server connected";
74    
75            my $command = $AUTOLOAD;
76            $command =~ s/.*://;
77    
78            warn "## $command ",Dumper(@_) if $self->{debug};
79    
80            my $send;
81    
82            if ( defined $bulk_command->{$command} ) {
83                    my $value = pop;
84                    $value = '' if ! defined $value;
85                    $send
86                            = uc($command)
87                            . ' '
88                            . join(' ', @_)
89                            . ' '
90                            . length( $value )
91                            . "\r\n$value\r\n"
92                            ;
93            } else {
94                    $send
95                            = uc($command)
96                            . ' '
97                            . join(' ', @_)
98                            . "\r\n"
99                            ;
100            }
101    
102            warn ">> $send" if $self->{debug};
103            print $sock $send;
104    
105            if ( $command eq 'quit' ) {
106                    close( $sock ) || die "can't close socket: $!";
107                    return 1;
108            }
109    
110            my $result = <$sock> || die "can't read socket: $!";
111            warn "<< $result" if $self->{debug};
112            my $type = substr($result,0,1);
113            $result = substr($result,1,-2);
114    
115            if ( $command eq 'info' ) {
116                    my $hash;
117                    foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
118                            my ($n,$v) = split(/:/, $l, 2);
119                            $hash->{$n} = $v;
120                    }
121                    return $hash;
122            } elsif ( $command eq 'keys' ) {
123                    my $keys = $self->__read_bulk($result);
124                    return split(/\s/, $keys) if $keys;
125                    return;
126            }
127    
128            if ( $type eq '-' ) {
129                    confess $result;
130            } elsif ( $type eq '+' ) {
131                    return $result;
132            } elsif ( $type eq '$' ) {
133                    return $self->__read_bulk($result);
134            } elsif ( $type eq '*' ) {
135                    return $self->__read_multi_bulk($result);
136            } elsif ( $type eq ':' ) {
137                    return $result; # FIXME check if int?
138            } else {
139                    confess "unknown type: $type", $self->__read_line();
140            }
141  }  }
142    
143  sub __sock_read_bulk {  sub __read_bulk {
144          my $len = <$sock>;          my ($self,$len) = @_;
145          warn "## bulk len: ",dump($len) if $debug;          return undef if $len < 0;
146          return undef if $len eq "nil\r\n";  
147          my $v;          my $v;
148          if ( $len > 0 ) {          if ( $len > 0 ) {
149                  read($sock, $v, $len) || die $!;                  read($self->{sock}, $v, $len) || die $!;
150                  warn "## bulk v: ",dump($v) if $debug;                  warn "<< ",Dumper($v),$/ if $self->{debug};
151          }          }
152          my $crlf;          my $crlf;
153          read($sock, $crlf, 2); # skip cr/lf          read($self->{sock}, $crlf, 2); # skip cr/lf
154          return $v;          return $v;
155  }  }
156    
157  sub _sock_result_bulk {  sub __read_multi_bulk {
158          my $self = shift;          my ($self,$size) = @_;
159          warn "## _sock_result_bulk ",dump( @_ ) if $debug;          return undef if $size < 0;
160          print $sock join(' ',@_) . "\r\n";          my $sock = $self->{sock};
         __sock_read_bulk();  
 }  
   
 sub _sock_result_bulk_list {  
         my $self = shift;  
         warn "## _sock_result_bulk_list ",dump( @_ ) if $debug;  
161    
         my $size = $self->_sock_send( @_ );  
         confess $size unless $size > 0;  
162          $size--;          $size--;
163    
164          my @list = ( 0 .. $size );          my @list = ( 0 .. $size );
165          foreach ( 0 .. $size ) {          foreach ( 0 .. $size ) {
166                  $list[ $_ ] = __sock_read_bulk();                  $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
167          }          }
168    
169          warn "## list = ", dump( @list ) if $debug;          warn "## list = ", Dumper( @list ) if $self->{debug};
170          return @list;          return @list;
171  }  }
172    
173  sub __sock_ok {  1;
         my $ok = <$sock>;  
         return undef if $ok eq "nil\r\n";  
         confess dump($ok) unless $ok eq "+OK\r\n";  
 }  
   
 sub _sock_send {  
         my $self = shift;  
         warn "## _sock_send ",dump( @_ ) if $debug;  
         print $sock join(' ',@_) . "\r\n";  
         __sock_result();  
 }  
   
 sub _sock_send_ok {  
         my $self = shift;  
         warn "## _sock_send_ok ",dump( @_ ) if $debug;  
         print $sock join(' ',@_) . "\r\n";  
         __sock_ok();  
 }  
   
 sub __sock_send_bulk_raw {  
         warn "## _sock_send_bulk ",dump( @_ ) if $debug;  
         my $value = pop;  
         $value = '' unless defined $value; # FIXME errr? nil?  
         print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n"  
 }  
   
 sub _sock_send_bulk {  
         my $self = shift;  
         __sock_send_bulk_raw( @_ );  
         __sock_ok();  
 }  
174    
175  sub _sock_send_bulk_number {  __END__
         my $self = shift;  
         __sock_send_bulk_raw( @_ );  
         my $v = __sock_result();  
         confess $v unless $v =~ m{^\-?\d+$};  
         return $v;  
 }  
176    
177  =head1 Connection Handling  =head1 Connection Handling
178    
# Line 145  sub _sock_send_bulk_number { Line 180  sub _sock_send_bulk_number {
180    
181    $r->quit;    $r->quit;
182    
 =cut  
   
 sub quit {  
         my $self = shift;  
   
         close( $sock ) || warn $!;  
 }  
   
183  =head2 ping  =head2 ping
184    
185    $r->ping || die "no server?";    $r->ping || die "no server?";
186    
 =cut  
   
 sub ping {  
         print $sock "PING\r\n";  
         my $pong = <$sock>;  
         die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";  
 }  
   
187  =head1 Commands operating on string values  =head1 Commands operating on string values
188    
189  =head2 set  =head2 set
190    
191    $r->set( foo => 'bar', $new );    $r->set( foo => 'bar' );
192    
193  =cut    $r->setnx( foo => 42 );
   
 sub set {  
         my ( $self, $key, $value, $new ) = @_;  
         $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );  
 }  
194    
195  =head2 get  =head2 get
196    
197    my $value = $r->get( 'foo' );    my $value = $r->get( 'foo' );
198    
 =cut  
   
 sub get {  
         my $self = shift;  
         $self->_sock_result_bulk('GET',@_);  
 }  
   
199  =head2 mget  =head2 mget
200    
201    my @values = $r->get( 'foo', 'bar', 'baz' );    my @values = $r->mget( 'foo', 'bar', 'baz' );
   
 =cut  
   
 sub mget {  
         my $self = shift;  
         $self->_sock_result_bulk_list('MGET',@_);  
 }  
202    
203  =head2 incr  =head2 incr
204    
205    $r->incr('counter');    $r->incr('counter');
   $r->incr('tripplets', 3);  
   
 =cut  
206    
207              $r->incrby('tripplets', 3);
   
 sub incr {  
         my $self = shift;  
         $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );  
 }  
208    
209  =head2 decr  =head2 decr
210    
211    $r->decr('counter');    $r->decr('counter');
   $r->decr('tripplets', 3);  
212    
213  =cut    $r->decrby('tripplets', 3);
   
 sub decr {  
         my $self = shift;  
         $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );  
 }  
214    
215  =head2 exists  =head2 exists
216    
217    $r->exists( 'key' ) && print "got key!";    $r->exists( 'key' ) && print "got key!";
218    
 =cut  
   
 sub exists {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'EXISTS', $key );  
 }  
   
219  =head2 del  =head2 del
220    
221    $r->del( 'key' ) || warn "key doesn't exist";    $r->del( 'key' ) || warn "key doesn't exist";
222    
 =cut  
   
 sub del {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'DEL', $key );  
 }  
   
223  =head2 type  =head2 type
224    
225    $r->type( 'key' ); # = string    $r->type( 'key' ); # = string
226    
 =cut  
   
 sub type {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'TYPE', $key );  
 }  
   
227  =head1 Commands operating on the key space  =head1 Commands operating on the key space
228    
229  =head2 keys  =head2 keys
230    
231    my @keys = $r->keys( '*glob_pattern*' );    my @keys = $r->keys( '*glob_pattern*' );
232    
 =cut  
   
 sub keys {  
         my ( $self, $glob ) = @_;  
         my $keys = $self->_sock_result_bulk( 'KEYS', $glob );  
         return split(/\s/, $keys) if $keys;  
         return () if wantarray;  
 }  
   
233  =head2 randomkey  =head2 randomkey
234    
235    my $key = $r->randomkey;    my $key = $r->randomkey;
236    
 =cut  
   
 sub randomkey {  
         my ( $self ) = @_;  
         $self->_sock_send( 'RANDOMKEY' );  
 }  
   
237  =head2 rename  =head2 rename
238    
239    my $ok = $r->rename( 'old-key', 'new-key', $new );    my $ok = $r->rename( 'old-key', 'new-key', $new );
240    
 =cut  
   
 sub rename {  
         my ( $self, $old, $new, $nx ) = @_;  
         $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );  
 }  
   
241  =head2 dbsize  =head2 dbsize
242    
243    my $nr_keys = $r->dbsize;    my $nr_keys = $r->dbsize;
244    
 =cut  
   
 sub dbsize {  
         my ( $self ) = @_;  
         $self->_sock_send('DBSIZE');  
 }  
   
245  =head1 Commands operating on lists  =head1 Commands operating on lists
246    
247  See also L<Redis::List> for tie interface.  See also L<Redis::List> for tie interface.
# Line 315  See also L<Redis::List> for tie interfac Line 250  See also L<Redis::List> for tie interfac
250    
251    $r->rpush( $key, $value );    $r->rpush( $key, $value );
252    
 =cut  
   
 sub rpush {  
         my ( $self, $key, $value ) = @_;  
         $self->_sock_send_bulk('RPUSH', $key, $value);  
 }  
   
253  =head2 lpush  =head2 lpush
254    
255    $r->lpush( $key, $value );    $r->lpush( $key, $value );
256    
 =cut  
   
 sub lpush {  
         my ( $self, $key, $value ) = @_;  
         $self->_sock_send_bulk('LPUSH', $key, $value);  
 }  
   
257  =head2 llen  =head2 llen
258    
259    $r->llen( $key );    $r->llen( $key );
260    
 =cut  
   
 sub llen {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'LLEN', $key );  
 }  
   
261  =head2 lrange  =head2 lrange
262    
263    my @list = $r->lrange( $key, $start, $end );    my @list = $r->lrange( $key, $start, $end );
264    
 =cut  
   
 sub lrange {  
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_result_bulk_list('LRANGE', $key, $start, $end);  
 }  
   
265  =head2 ltrim  =head2 ltrim
266    
267    my $ok = $r->ltrim( $key, $start, $end );    my $ok = $r->ltrim( $key, $start, $end );
268    
 =cut  
   
 sub ltrim {  
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_send_ok( 'LTRIM', $key, $start, $end );  
 }  
   
269  =head2 lindex  =head2 lindex
270    
271    $r->lindex( $key, $index );    $r->lindex( $key, $index );
272    
 =cut  
   
 sub lindex {  
         my ( $self, $key, $index ) = @_;  
         $self->_sock_result_bulk( 'LINDEX', $key, $index );  
 }  
   
273  =head2 lset  =head2 lset
274    
275    $r->lset( $key, $index, $value );    $r->lset( $key, $index, $value );
276    
 =cut  
   
 sub lset {  
         my ( $self, $key, $index, $value ) = @_;  
         $self->_sock_send_bulk( 'LSET', $key, $index, $value );  
 }  
   
277  =head2 lrem  =head2 lrem
278    
279    my $modified_count = $r->lrem( $key, $count, $value );    my $modified_count = $r->lrem( $key, $count, $value );
280    
 =cut  
   
 sub lrem {  
         my ( $self, $key, $count, $value ) = @_;  
         $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );  
 }  
   
281  =head2 lpop  =head2 lpop
282    
283    my $value = $r->lpop( $key );    my $value = $r->lpop( $key );
284    
 =cut  
   
 sub lpop {  
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'LPOP', $key );  
 }  
   
285  =head2 rpop  =head2 rpop
286    
287    my $value = $r->rpop( $key );    my $value = $r->rpop( $key );
288    
 =cut  
   
 sub rpop {  
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'RPOP', $key );  
 }  
   
289  =head1 Commands operating on sets  =head1 Commands operating on sets
290    
291  =head2 sadd  =head2 sadd
292    
293    $r->sadd( $key, $member );    $r->sadd( $key, $member );
294    
 =cut  
   
 sub sadd {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SADD', $key, $member );  
 }  
   
295  =head2 srem  =head2 srem
296    
297    $r->srem( $key, $member );    $r->srem( $key, $member );
298    
 =cut  
   
 sub srem {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SREM', $key, $member );  
 }  
   
299  =head2 scard  =head2 scard
300    
301    my $elements = $r->scard( $key );    my $elements = $r->scard( $key );
302    
 =cut  
   
 sub scard {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'SCARD', $key );  
 }  
   
303  =head2 sismember  =head2 sismember
304    
305    $r->sismember( $key, $member );    $r->sismember( $key, $member );
306    
 =cut  
   
 sub sismember {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member );  
 }  
   
307  =head2 sinter  =head2 sinter
308    
309    $r->sinter( $key1, $key2, ... );    $r->sinter( $key1, $key2, ... );
310    
 =cut  
   
 sub sinter {  
         my $self = shift;  
         $self->_sock_result_bulk_list( 'SINTER', @_ );  
 }  
   
311  =head2 sinterstore  =head2 sinterstore
312    
313    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
314    
 =cut  
   
 sub sinterstore {  
         my $self = shift;  
         $self->_sock_send_ok( 'SINTERSTORE', @_ );  
 }  
   
315  =head1 Multiple databases handling commands  =head1 Multiple databases handling commands
316    
317  =head2 select  =head2 select
318    
319    $r->select( $dbindex ); # 0 for new clients    $r->select( $dbindex ); # 0 for new clients
320    
 =cut  
   
 sub select {  
         my ($self,$dbindex) = @_;  
         confess dump($dbindex) . 'not number' unless $dbindex =~ m{^\d+$};  
         $self->_sock_send_ok( 'SELECT', $dbindex );  
 }  
   
321  =head2 move  =head2 move
322    
323    $r->move( $key, $dbindex );    $r->move( $key, $dbindex );
324    
 =cut  
   
 sub move {  
         my ( $self, $key, $dbindex ) = @_;  
         $self->_sock_send( 'MOVE', $key, $dbindex );  
 }  
   
325  =head2 flushdb  =head2 flushdb
326    
327    $r->flushdb;    $r->flushdb;
328    
 =cut  
   
 sub flushdb {  
         my $self = shift;  
         $self->_sock_send_ok('FLUSHDB');  
 }  
   
329  =head2 flushall  =head2 flushall
330    
331    $r->flushall;    $r->flushall;
332    
 =cut  
   
 sub flushall {  
         my $self = shift;  
         $self->_sock_send_ok('flushall');  
 }  
   
333  =head1 Sorting  =head1 Sorting
334    
335    =head2 sort
336    
337    $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');    $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
338    
339  =cut  =head1 Persistence control commands
340    
341  sub sort {  =head2 save
342          my ( $self, $sort ) = @_;  
343          $self->_sock_result_bulk_list( "SORT $sort" );    $r->save;
344  }  
345    =head2 bgsave
346    
347      $r->bgsave;
348    
349    =head2 lastsave
350    
351      $r->lastsave;
352    
353    =head2 shutdown
354    
355      $r->shutdown;
356    
357    =head1 Remote server control commands
358    
359    =head2 info
360    
361      my $info_hash = $r->info;
362    
363  =head1 AUTHOR  =head1 AUTHOR
364    
# Line 565  automatically be notified of progress on Line 378  automatically be notified of progress on
378  You can find documentation for this module with the perldoc command.  You can find documentation for this module with the perldoc command.
379    
380      perldoc Redis      perldoc Redis
381            perldoc Redis::List
382            perldoc Redis::Hash
383    
384    
385  You can also look for information at:  You can also look for information at:
Legend:
Removed from v.47  
changed lines
  Added in v.63
  ViewVC Help
Powered by ViewVC 1.1.26