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