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

Legend:
Removed from v.47  
changed lines
  Added in v.66

  ViewVC Help
Powered by ViewVC 1.1.26