/[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 69 by dpavlin, Wed Mar 17 18:22:09 2010 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 = '1.2001';
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 supports protocol 1.2 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            getset => 1,
65            smove => 1,
66            zadd => 1,
67            zrem => 1,
68            zscore => 1,
69            zincrby => 1,
70            append => 1,
71    };
72    
73    # we don't want DESTROY to fallback into AUTOLOAD
74    sub DESTROY {}
75    
76    our $AUTOLOAD;
77    sub AUTOLOAD {
78            my $self = shift;
79    
80            use bytes;
81    
82            my $sock = $self->{sock} || die "no server connected";
83    
84            my $command = $AUTOLOAD;
85            $command =~ s/.*://;
86    
87            warn "## $command ",Dumper(@_) if $self->{debug};
88    
89            my $send;
90    
91            if ( defined $bulk_command->{$command} ) {
92                    my $value = pop;
93                    $value = '' if ! defined $value;
94                    $send
95                            = uc($command)
96                            . ' '
97                            . join(' ', @_)
98                            . ' '
99                            . length( $value )
100                            . "\r\n$value\r\n"
101                            ;
102            } else {
103                    $send
104                            = uc($command)
105                            . ' '
106                            . join(' ', @_)
107                            . "\r\n"
108                            ;
109            }
110    
111            warn ">> $send" if $self->{debug};
112            print $sock $send;
113    
114            if ( $command eq 'quit' ) {
115                    close( $sock ) || die "can't close socket: $!";
116                    return 1;
117            }
118    
119            my $result = <$sock> || die "can't read socket: $!";
120            warn "<< $result" if $self->{debug};
121            my $type = substr($result,0,1);
122            $result = substr($result,1,-2);
123    
124            if ( $command eq 'info' ) {
125                    my $hash;
126                    foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
127                            my ($n,$v) = split(/:/, $l, 2);
128                            $hash->{$n} = $v;
129                    }
130                    return $hash;
131            } elsif ( $command eq 'keys' ) {
132                    my $keys = $self->__read_bulk($result);
133                    return split(/\s/, $keys) if $keys;
134                    return;
135            }
136    
137            if ( $type eq '-' ) {
138                    confess "[$command] $result";
139            } elsif ( $type eq '+' ) {
140                    return $result;
141            } elsif ( $type eq '$' ) {
142                    return $self->__read_bulk($result);
143            } elsif ( $type eq '*' ) {
144                    return $self->__read_multi_bulk($result);
145            } elsif ( $type eq ':' ) {
146                    return $result; # FIXME check if int?
147            } else {
148                    confess "unknown type: $type", $self->__read_line();
149            }
150  }  }
151    
152  sub __sock_read_bulk {  sub __read_bulk {
153          my $len = <$sock>;          my ($self,$len) = @_;
154          warn "## bulk len: ",dump($len) if $debug;          return undef if $len < 0;
155          return undef if $len eq "nil\r\n";  
156          my $v;          my $v;
157          if ( $len > 0 ) {          if ( $len > 0 ) {
158                  read($sock, $v, $len) || die $!;                  read($self->{sock}, $v, $len) || die $!;
159                  warn "## bulk v: ",dump($v) if $debug;                  warn "<< ",Dumper($v),$/ if $self->{debug};
160          }          }
161          my $crlf;          my $crlf;
162          read($sock, $crlf, 2); # skip cr/lf          read($self->{sock}, $crlf, 2); # skip cr/lf
163          return $v;          return $v;
164  }  }
165    
166  sub _sock_result_bulk {  sub __read_multi_bulk {
167          my $self = shift;          my ($self,$size) = @_;
168          warn "## _sock_result_bulk ",dump( @_ ) if $debug;          return undef if $size < 0;
169          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;  
170    
         my $size = $self->_sock_send( @_ );  
         confess $size unless $size > 0;  
171          $size--;          $size--;
172    
173          my @list = ( 0 .. $size );          my @list = ( 0 .. $size );
174          foreach ( 0 .. $size ) {          foreach ( 0 .. $size ) {
175                  $list[ $_ ] = __sock_read_bulk();                  $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
176          }          }
177    
178          warn "## list = ", dump( @list ) if $debug;          warn "## list = ", Dumper( @list ) if $self->{debug};
179          return @list;          return @list;
180  }  }
181    
182  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();  
 }  
183    
184  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;  
 }  
185    
186  =head1 Connection Handling  =head1 Connection Handling
187    
# Line 145  sub _sock_send_bulk_number { Line 189  sub _sock_send_bulk_number {
189    
190    $r->quit;    $r->quit;
191    
 =cut  
   
 sub quit {  
         my $self = shift;  
   
         close( $sock ) || warn $!;  
 }  
   
192  =head2 ping  =head2 ping
193    
194    $r->ping || die "no server?";    $r->ping || die "no server?";
195    
 =cut  
   
 sub ping {  
         print $sock "PING\r\n";  
         my $pong = <$sock>;  
         die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";  
 }  
   
196  =head1 Commands operating on string values  =head1 Commands operating on string values
197    
198  =head2 set  =head2 set
199    
200    $r->set( foo => 'bar', $new );    $r->set( foo => 'bar' );
201    
202  =cut    $r->setnx( foo => 42 );
   
 sub set {  
         my ( $self, $key, $value, $new ) = @_;  
         $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );  
 }  
203    
204  =head2 get  =head2 get
205    
206    my $value = $r->get( 'foo' );    my $value = $r->get( 'foo' );
207    
 =cut  
   
 sub get {  
         my $self = shift;  
         $self->_sock_result_bulk('GET',@_);  
 }  
   
208  =head2 mget  =head2 mget
209    
210    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',@_);  
 }  
211    
212  =head2 incr  =head2 incr
213    
214    $r->incr('counter');    $r->incr('counter');
   $r->incr('tripplets', 3);  
   
 =cut  
215    
216              $r->incrby('tripplets', 3);
   
 sub incr {  
         my $self = shift;  
         $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );  
 }  
217    
218  =head2 decr  =head2 decr
219    
220    $r->decr('counter');    $r->decr('counter');
   $r->decr('tripplets', 3);  
221    
222  =cut    $r->decrby('tripplets', 3);
   
 sub decr {  
         my $self = shift;  
         $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );  
 }  
223    
224  =head2 exists  =head2 exists
225    
226    $r->exists( 'key' ) && print "got key!";    $r->exists( 'key' ) && print "got key!";
227    
 =cut  
   
 sub exists {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'EXISTS', $key );  
 }  
   
228  =head2 del  =head2 del
229    
230    $r->del( 'key' ) || warn "key doesn't exist";    $r->del( 'key' ) || warn "key doesn't exist";
231    
 =cut  
   
 sub del {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'DEL', $key );  
 }  
   
232  =head2 type  =head2 type
233    
234    $r->type( 'key' ); # = string    $r->type( 'key' ); # = string
235    
 =cut  
   
 sub type {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'TYPE', $key );  
 }  
   
236  =head1 Commands operating on the key space  =head1 Commands operating on the key space
237    
238  =head2 keys  =head2 keys
239    
240    my @keys = $r->keys( '*glob_pattern*' );    my @keys = $r->keys( '*glob_pattern*' );
241    
 =cut  
   
 sub keys {  
         my ( $self, $glob ) = @_;  
         my $keys = $self->_sock_result_bulk( 'KEYS', $glob );  
         return split(/\s/, $keys) if $keys;  
         return () if wantarray;  
 }  
   
242  =head2 randomkey  =head2 randomkey
243    
244    my $key = $r->randomkey;    my $key = $r->randomkey;
245    
 =cut  
   
 sub randomkey {  
         my ( $self ) = @_;  
         $self->_sock_send( 'RANDOMKEY' );  
 }  
   
246  =head2 rename  =head2 rename
247    
248    my $ok = $r->rename( 'old-key', 'new-key', $new );    my $ok = $r->rename( 'old-key', 'new-key', $new );
249    
 =cut  
   
 sub rename {  
         my ( $self, $old, $new, $nx ) = @_;  
         $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );  
 }  
   
250  =head2 dbsize  =head2 dbsize
251    
252    my $nr_keys = $r->dbsize;    my $nr_keys = $r->dbsize;
253    
 =cut  
   
 sub dbsize {  
         my ( $self ) = @_;  
         $self->_sock_send('DBSIZE');  
 }  
   
254  =head1 Commands operating on lists  =head1 Commands operating on lists
255    
256  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 259  See also L<Redis::List> for tie interfac
259    
260    $r->rpush( $key, $value );    $r->rpush( $key, $value );
261    
 =cut  
   
 sub rpush {  
         my ( $self, $key, $value ) = @_;  
         $self->_sock_send_bulk('RPUSH', $key, $value);  
 }  
   
262  =head2 lpush  =head2 lpush
263    
264    $r->lpush( $key, $value );    $r->lpush( $key, $value );
265    
 =cut  
   
 sub lpush {  
         my ( $self, $key, $value ) = @_;  
         $self->_sock_send_bulk('LPUSH', $key, $value);  
 }  
   
266  =head2 llen  =head2 llen
267    
268    $r->llen( $key );    $r->llen( $key );
269    
 =cut  
   
 sub llen {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'LLEN', $key );  
 }  
   
270  =head2 lrange  =head2 lrange
271    
272    my @list = $r->lrange( $key, $start, $end );    my @list = $r->lrange( $key, $start, $end );
273    
 =cut  
   
 sub lrange {  
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_result_bulk_list('LRANGE', $key, $start, $end);  
 }  
   
274  =head2 ltrim  =head2 ltrim
275    
276    my $ok = $r->ltrim( $key, $start, $end );    my $ok = $r->ltrim( $key, $start, $end );
277    
 =cut  
   
 sub ltrim {  
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_send_ok( 'LTRIM', $key, $start, $end );  
 }  
   
278  =head2 lindex  =head2 lindex
279    
280    $r->lindex( $key, $index );    $r->lindex( $key, $index );
281    
 =cut  
   
 sub lindex {  
         my ( $self, $key, $index ) = @_;  
         $self->_sock_result_bulk( 'LINDEX', $key, $index );  
 }  
   
282  =head2 lset  =head2 lset
283    
284    $r->lset( $key, $index, $value );    $r->lset( $key, $index, $value );
285    
 =cut  
   
 sub lset {  
         my ( $self, $key, $index, $value ) = @_;  
         $self->_sock_send_bulk( 'LSET', $key, $index, $value );  
 }  
   
286  =head2 lrem  =head2 lrem
287    
288    my $modified_count = $r->lrem( $key, $count, $value );    my $modified_count = $r->lrem( $key, $count, $value );
289    
 =cut  
   
 sub lrem {  
         my ( $self, $key, $count, $value ) = @_;  
         $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );  
 }  
   
290  =head2 lpop  =head2 lpop
291    
292    my $value = $r->lpop( $key );    my $value = $r->lpop( $key );
293    
 =cut  
   
 sub lpop {  
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'LPOP', $key );  
 }  
   
294  =head2 rpop  =head2 rpop
295    
296    my $value = $r->rpop( $key );    my $value = $r->rpop( $key );
297    
 =cut  
   
 sub rpop {  
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'RPOP', $key );  
 }  
   
298  =head1 Commands operating on sets  =head1 Commands operating on sets
299    
300  =head2 sadd  =head2 sadd
301    
302    $r->sadd( $key, $member );    $r->sadd( $key, $member );
303    
 =cut  
   
 sub sadd {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SADD', $key, $member );  
 }  
   
304  =head2 srem  =head2 srem
305    
306    $r->srem( $key, $member );    $r->srem( $key, $member );
307    
 =cut  
   
 sub srem {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SREM', $key, $member );  
 }  
   
308  =head2 scard  =head2 scard
309    
310    my $elements = $r->scard( $key );    my $elements = $r->scard( $key );
311    
 =cut  
   
 sub scard {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'SCARD', $key );  
 }  
   
312  =head2 sismember  =head2 sismember
313    
314    $r->sismember( $key, $member );    $r->sismember( $key, $member );
315    
 =cut  
   
 sub sismember {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member );  
 }  
   
316  =head2 sinter  =head2 sinter
317    
318    $r->sinter( $key1, $key2, ... );    $r->sinter( $key1, $key2, ... );
319    
 =cut  
   
 sub sinter {  
         my $self = shift;  
         $self->_sock_result_bulk_list( 'SINTER', @_ );  
 }  
   
320  =head2 sinterstore  =head2 sinterstore
321    
322    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
323    
 =cut  
   
 sub sinterstore {  
         my $self = shift;  
         $self->_sock_send_ok( 'SINTERSTORE', @_ );  
 }  
   
324  =head1 Multiple databases handling commands  =head1 Multiple databases handling commands
325    
326  =head2 select  =head2 select
327    
328    $r->select( $dbindex ); # 0 for new clients    $r->select( $dbindex ); # 0 for new clients
329    
 =cut  
   
 sub select {  
         my ($self,$dbindex) = @_;  
         confess dump($dbindex) . 'not number' unless $dbindex =~ m{^\d+$};  
         $self->_sock_send_ok( 'SELECT', $dbindex );  
 }  
   
330  =head2 move  =head2 move
331    
332    $r->move( $key, $dbindex );    $r->move( $key, $dbindex );
333    
 =cut  
   
 sub move {  
         my ( $self, $key, $dbindex ) = @_;  
         $self->_sock_send( 'MOVE', $key, $dbindex );  
 }  
   
334  =head2 flushdb  =head2 flushdb
335    
336    $r->flushdb;    $r->flushdb;
337    
 =cut  
   
 sub flushdb {  
         my $self = shift;  
         $self->_sock_send_ok('FLUSHDB');  
 }  
   
338  =head2 flushall  =head2 flushall
339    
340    $r->flushall;    $r->flushall;
341    
 =cut  
   
 sub flushall {  
         my $self = shift;  
         $self->_sock_send_ok('flushall');  
 }  
   
342  =head1 Sorting  =head1 Sorting
343    
344    =head2 sort
345    
346    $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');
347    
348  =cut  =head1 Persistence control commands
349    
350  sub sort {  =head2 save
351          my ( $self, $sort ) = @_;  
352          $self->_sock_result_bulk_list( "SORT $sort" );    $r->save;
353  }  
354    =head2 bgsave
355    
356      $r->bgsave;
357    
358    =head2 lastsave
359    
360      $r->lastsave;
361    
362    =head2 shutdown
363    
364      $r->shutdown;
365    
366    =head1 Remote server control commands
367    
368    =head2 info
369    
370      my $info_hash = $r->info;
371    
372  =head1 AUTHOR  =head1 AUTHOR
373    
# Line 565  automatically be notified of progress on Line 387  automatically be notified of progress on
387  You can find documentation for this module with the perldoc command.  You can find documentation for this module with the perldoc command.
388    
389      perldoc Redis      perldoc Redis
390            perldoc Redis::List
391            perldoc Redis::Hash
392    
393    
394  You can also look for information at:  You can also look for information at:
# Line 595  L<http://search.cpan.org/dist/Redis> Line 419  L<http://search.cpan.org/dist/Redis>
419    
420  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
421    
422  Copyright 2009 Dobrica Pavlinusic, all rights reserved.  Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
423    
424  This program is free software; you can redistribute it and/or modify it  This program is free software; you can redistribute it and/or modify it
425  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.47  
changed lines
  Added in v.69
  ViewVC Help
Powered by ViewVC 1.1.26