/[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 52 by dpavlin, Mon Mar 23 11:44:25 2009 UTC revision 53 by dpavlin, Tue Mar 24 22:51:53 2009 UTC
# 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.08';
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 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      my $r = Redis->new;
38    
39  =cut  =cut
40    
41  our $debug = $ENV{REDIS} || 0;  our $debug = $ENV{REDIS} || 0;
# Line 53  sub new { Line 58  sub new {
58          $self;          $self;
59  }  }
60    
61  sub __sock_result {  my $bulk_command = {
62          my $result = <$sock>;          set => 1,       setnx => 1,
63          warn "## result: ",dump( $result ) if $debug;          rpush => 1,     lpush => 1,
64          $result =~ s{\r\n$}{} || warn "can't find cr/lf";          lset => 1,      lrem => 1,
65          return $result;          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 {  sub __sock_read_bulk {
143          my $len = <$sock>;          my $len = shift;
144          warn "## bulk len: ",dump($len) if $debug;          return undef if $len < 0;
145          return undef if $len eq "nil\r\n";  
146          my $v;          my $v;
147          if ( $len > 0 ) {          if ( $len > 0 ) {
148                  read($sock, $v, $len) || die $!;                  read($sock, $v, $len) || die $!;
149                  warn "## bulk v: ",dump($v) if $debug;                  warn "<< ",dump($v),$/ if $debug;
150          }          }
151          my $crlf;          my $crlf;
152          read($sock, $crlf, 2); # skip cr/lf          read($sock, $crlf, 2); # skip cr/lf
153          return $v;          return $v;
154  }  }
155    
156  sub _sock_result_bulk {  sub __sock_read_multi_bulk {
157          my $self = shift;          my $size = shift;
158          warn "## _sock_result_bulk ",dump( @_ ) if $debug;          return undef if $size < 0;
         print $sock join(' ',@_) . "\r\n";  
         __sock_read_bulk();  
 }  
   
 sub _sock_result_bulk_list {  
         my $self = shift;  
         warn "## _sock_result_bulk_list ",dump( @_ ) if $debug;  
159    
         my $size = $self->_sock_send( @_ );  
         confess $size unless $size > 0;  
160          $size--;          $size--;
161    
162          my @list = ( 0 .. $size );          my @list = ( 0 .. $size );
163          foreach ( 0 .. $size ) {          foreach ( 0 .. $size ) {
164                  $list[ $_ ] = __sock_read_bulk();                  $list[ $_ ] = __sock_read_bulk( substr(<$sock>,1,-2) );
165          }          }
166    
167          warn "## list = ", dump( @list ) if $debug;          warn "## list = ", dump( @list ) if $debug;
168          return @list;          return @list;
169  }  }
170    
171  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();  
 }  
172    
173  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;  
 }  
174    
175  =head1 Connection Handling  =head1 Connection Handling
176    
# Line 145  sub _sock_send_bulk_number { Line 178  sub _sock_send_bulk_number {
178    
179    $r->quit;    $r->quit;
180    
 =cut  
   
 sub quit {  
         my $self = shift;  
   
         close( $sock ) || warn $!;  
 }  
   
181  =head2 ping  =head2 ping
182    
183    $r->ping || die "no server?";    $r->ping || die "no server?";
184    
 =cut  
   
 sub ping {  
         print $sock "PING\r\n";  
         my $pong = <$sock>;  
         die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";  
 }  
   
185  =head1 Commands operating on string values  =head1 Commands operating on string values
186    
187  =head2 set  =head2 set
188    
189    $r->set( foo => 'bar', $new );    $r->set( foo => 'bar' );
190    
191  =cut    $r->setnx( foo => 42 );
   
 sub set {  
         my ( $self, $key, $value, $new ) = @_;  
         $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );  
 }  
192    
193  =head2 get  =head2 get
194    
195    my $value = $r->get( 'foo' );    my $value = $r->get( 'foo' );
196    
 =cut  
   
 sub get {  
         my $self = shift;  
         $self->_sock_result_bulk('GET',@_);  
 }  
   
197  =head2 mget  =head2 mget
198    
199    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',@_);  
 }  
200    
201  =head2 incr  =head2 incr
202    
203    $r->incr('counter');    $r->incr('counter');
   $r->incr('tripplets', 3);  
   
 =cut  
204    
205              $r->incrby('tripplets', 3);
   
 sub incr {  
         my $self = shift;  
         $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );  
 }  
206    
207  =head2 decr  =head2 decr
208    
209    $r->decr('counter');    $r->decr('counter');
   $r->decr('tripplets', 3);  
210    
211  =cut    $r->decrby('tripplets', 3);
   
 sub decr {  
         my $self = shift;  
         $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );  
 }  
212    
213  =head2 exists  =head2 exists
214    
215    $r->exists( 'key' ) && print "got key!";    $r->exists( 'key' ) && print "got key!";
216    
 =cut  
   
 sub exists {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'EXISTS', $key );  
 }  
   
217  =head2 del  =head2 del
218    
219    $r->del( 'key' ) || warn "key doesn't exist";    $r->del( 'key' ) || warn "key doesn't exist";
220    
 =cut  
   
 sub del {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'DEL', $key );  
 }  
   
221  =head2 type  =head2 type
222    
223    $r->type( 'key' ); # = string    $r->type( 'key' ); # = string
224    
 =cut  
   
 sub type {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'TYPE', $key );  
 }  
   
225  =head1 Commands operating on the key space  =head1 Commands operating on the key space
226    
227  =head2 keys  =head2 keys
228    
229    my @keys = $r->keys( '*glob_pattern*' );    my @keys = $r->keys( '*glob_pattern*' );
230    
 =cut  
   
 sub keys {  
         my ( $self, $glob ) = @_;  
         my $keys = $self->_sock_result_bulk( 'KEYS', $glob );  
         return split(/\s/, $keys) if $keys;  
         return () if wantarray;  
 }  
   
231  =head2 randomkey  =head2 randomkey
232    
233    my $key = $r->randomkey;    my $key = $r->randomkey;
234    
 =cut  
   
 sub randomkey {  
         my ( $self ) = @_;  
         $self->_sock_send( 'RANDOMKEY' );  
 }  
   
235  =head2 rename  =head2 rename
236    
237    my $ok = $r->rename( 'old-key', 'new-key', $new );    my $ok = $r->rename( 'old-key', 'new-key', $new );
238    
 =cut  
   
 sub rename {  
         my ( $self, $old, $new, $nx ) = @_;  
         $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );  
 }  
   
239  =head2 dbsize  =head2 dbsize
240    
241    my $nr_keys = $r->dbsize;    my $nr_keys = $r->dbsize;
242    
 =cut  
   
 sub dbsize {  
         my ( $self ) = @_;  
         $self->_sock_send('DBSIZE');  
 }  
   
243  =head1 Commands operating on lists  =head1 Commands operating on lists
244    
245  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 248  See also L<Redis::List> for tie interfac
248    
249    $r->rpush( $key, $value );    $r->rpush( $key, $value );
250    
 =cut  
   
 sub rpush {  
         my ( $self, $key, $value ) = @_;  
         $self->_sock_send_bulk('RPUSH', $key, $value);  
 }  
   
251  =head2 lpush  =head2 lpush
252    
253    $r->lpush( $key, $value );    $r->lpush( $key, $value );
254    
 =cut  
   
 sub lpush {  
         my ( $self, $key, $value ) = @_;  
         $self->_sock_send_bulk('LPUSH', $key, $value);  
 }  
   
255  =head2 llen  =head2 llen
256    
257    $r->llen( $key );    $r->llen( $key );
258    
 =cut  
   
 sub llen {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'LLEN', $key );  
 }  
   
259  =head2 lrange  =head2 lrange
260    
261    my @list = $r->lrange( $key, $start, $end );    my @list = $r->lrange( $key, $start, $end );
262    
 =cut  
   
 sub lrange {  
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_result_bulk_list('LRANGE', $key, $start, $end);  
 }  
   
263  =head2 ltrim  =head2 ltrim
264    
265    my $ok = $r->ltrim( $key, $start, $end );    my $ok = $r->ltrim( $key, $start, $end );
266    
 =cut  
   
 sub ltrim {  
         my ( $self, $key, $start, $end ) = @_;  
         $self->_sock_send_ok( 'LTRIM', $key, $start, $end );  
 }  
   
267  =head2 lindex  =head2 lindex
268    
269    $r->lindex( $key, $index );    $r->lindex( $key, $index );
270    
 =cut  
   
 sub lindex {  
         my ( $self, $key, $index ) = @_;  
         $self->_sock_result_bulk( 'LINDEX', $key, $index );  
 }  
   
271  =head2 lset  =head2 lset
272    
273    $r->lset( $key, $index, $value );    $r->lset( $key, $index, $value );
274    
 =cut  
   
 sub lset {  
         my ( $self, $key, $index, $value ) = @_;  
         $self->_sock_send_bulk( 'LSET', $key, $index, $value );  
 }  
   
275  =head2 lrem  =head2 lrem
276    
277    my $modified_count = $r->lrem( $key, $count, $value );    my $modified_count = $r->lrem( $key, $count, $value );
278    
 =cut  
   
 sub lrem {  
         my ( $self, $key, $count, $value ) = @_;  
         $self->_sock_send_bulk_number( 'LREM', $key, $count, $value );  
 }  
   
279  =head2 lpop  =head2 lpop
280    
281    my $value = $r->lpop( $key );    my $value = $r->lpop( $key );
282    
 =cut  
   
 sub lpop {  
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'LPOP', $key );  
 }  
   
283  =head2 rpop  =head2 rpop
284    
285    my $value = $r->rpop( $key );    my $value = $r->rpop( $key );
286    
 =cut  
   
 sub rpop {  
         my ( $self, $key ) = @_;  
         $self->_sock_result_bulk( 'RPOP', $key );  
 }  
   
287  =head1 Commands operating on sets  =head1 Commands operating on sets
288    
289  =head2 sadd  =head2 sadd
290    
291    $r->sadd( $key, $member );    $r->sadd( $key, $member );
292    
 =cut  
   
 sub sadd {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SADD', $key, $member );  
 }  
   
293  =head2 srem  =head2 srem
294    
295    $r->srem( $key, $member );    $r->srem( $key, $member );
296    
 =cut  
   
 sub srem {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SREM', $key, $member );  
 }  
   
297  =head2 scard  =head2 scard
298    
299    my $elements = $r->scard( $key );    my $elements = $r->scard( $key );
300    
 =cut  
   
 sub scard {  
         my ( $self, $key ) = @_;  
         $self->_sock_send( 'SCARD', $key );  
 }  
   
301  =head2 sismember  =head2 sismember
302    
303    $r->sismember( $key, $member );    $r->sismember( $key, $member );
304    
 =cut  
   
 sub sismember {  
         my ( $self, $key, $member ) = @_;  
         $self->_sock_send_bulk_number( 'SISMEMBER', $key, $member );  
 }  
   
305  =head2 sinter  =head2 sinter
306    
307    $r->sinter( $key1, $key2, ... );    $r->sinter( $key1, $key2, ... );
308    
 =cut  
   
 sub sinter {  
         my $self = shift;  
         $self->_sock_result_bulk_list( 'SINTER', @_ );  
 }  
   
309  =head2 sinterstore  =head2 sinterstore
310    
311    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );    my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
312    
 =cut  
   
 sub sinterstore {  
         my $self = shift;  
         $self->_sock_send_ok( 'SINTERSTORE', @_ );  
 }  
   
313  =head1 Multiple databases handling commands  =head1 Multiple databases handling commands
314    
315  =head2 select  =head2 select
316    
317    $r->select( $dbindex ); # 0 for new clients    $r->select( $dbindex ); # 0 for new clients
318    
 =cut  
   
 sub select {  
         my ($self,$dbindex) = @_;  
         confess dump($dbindex) . 'not number' unless $dbindex =~ m{^\d+$};  
         $self->_sock_send_ok( 'SELECT', $dbindex );  
 }  
   
319  =head2 move  =head2 move
320    
321    $r->move( $key, $dbindex );    $r->move( $key, $dbindex );
322    
 =cut  
   
 sub move {  
         my ( $self, $key, $dbindex ) = @_;  
         $self->_sock_send( 'MOVE', $key, $dbindex );  
 }  
   
323  =head2 flushdb  =head2 flushdb
324    
325    $r->flushdb;    $r->flushdb;
326    
 =cut  
   
 sub flushdb {  
         my $self = shift;  
         $self->_sock_send_ok('FLUSHDB');  
 }  
   
327  =head2 flushall  =head2 flushall
328    
329    $r->flushall;    $r->flushall;
330    
 =cut  
   
 sub flushall {  
         my $self = shift;  
         $self->_sock_send_ok('flushall');  
 }  
   
331  =head1 Sorting  =head1 Sorting
332    
333  =head2 sort  =head2 sort
334    
335    $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');
336    
 =cut  
   
 sub sort {  
         my ( $self, $sort ) = @_;  
         $self->_sock_result_bulk_list( "SORT $sort" );  
 }  
   
337  =head1 Persistence control commands  =head1 Persistence control commands
338    
339  =head2 save  =head2 save
340    
341    $r->save;    $r->save;
342    
 =cut  
   
 sub save {  
         my $self = shift;  
         $self->_sock_send_ok( 'SAVE' );  
 }  
   
343  =head2 bgsave  =head2 bgsave
344    
345    $r->bgsave;    $r->bgsave;
346    
 =cut  
   
 sub bgsave {  
         my $self = shift;  
         $self->_sock_send_ok( 'BGSAVE' );  
 }  
   
347  =head2 lastsave  =head2 lastsave
348    
349    $r->lastsave;    $r->lastsave;
350    
 =cut  
   
 sub lastsave {  
         my $self = shift;  
         $self->_sock_send( 'LASTSAVE' );  
 }  
   
351  =head2 shutdown  =head2 shutdown
352    
353    $r->shutdown;    $r->shutdown;
354    
 =cut  
   
 sub shutdown {  
         my $self = shift;  
         $self->_sock_send( 'SHUTDOWN' );  
 }  
   
355  =head1 Remote server control commands  =head1 Remote server control commands
356    
357  =head2 info  =head2 info
358    
359    my $info_hash = $r->info;    my $info_hash = $r->info;
360    
 =cut  
   
 sub info {  
         my $self = shift;  
         my $info = $self->_sock_result_bulk( 'INFO' );  
         my $hash;  
         foreach my $l ( split(/\r\n/, $info ) ) {  
                 my ($n,$v) = split(/:/, $l, 2);  
                 $hash->{$n} = $v;  
         }  
         return $hash;  
 }  
   
361  =head1 AUTHOR  =head1 AUTHOR
362    
363  Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
# Line 632  automatically be notified of progress on Line 376  automatically be notified of progress on
376  You can find documentation for this module with the perldoc command.  You can find documentation for this module with the perldoc command.
377    
378      perldoc Redis      perldoc Redis
379            perldoc Redis::List
380            perldoc Redis::Hash
381    
382    
383  You can also look for information at:  You can also look for information at:

Legend:
Removed from v.52  
changed lines
  Added in v.53

  ViewVC Help
Powered by ViewVC 1.1.26