/[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 21 by dpavlin, Sun Mar 22 10:36:22 2009 UTC revision 53 by dpavlin, Tue Mar 24 22:51:53 2009 UTC
# Line 9  use Carp qw/confess/; Line 9  use Carp qw/confess/;
9    
10  =head1 NAME  =head1 NAME
11    
12  Redis - The great new Redis!  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      use Redis;  This version support git version 0.08 of Redis available at
   
     my $r = Redis->new();  
   
24    
25    L<git://github.com/antirez/redis>
26    
27    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;
42    
43  our $sock;  our $sock;
44  my $server = '127.0.0.1:6379';  my $server = '127.0.0.1:6379';
45    
# Line 51  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 );          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);          return undef if $len < 0;
145          return undef if $len eq "nil\r\n";  
146          my $v;          my $v;
147          read($sock, $v, $len) || die $!;          if ( $len > 0 ) {
148          warn "## bulk v: ",dump($v);                  read($sock, $v, $len) || die $!;
149                    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( @_ );          return undef if $size < 0;
         print $sock join(' ',@_) . "\r\n";  
         _sock_read_bulk();  
 }  
159    
160  sub _sock_ok {          $size--;
         my $ok = <$sock>;  
         confess dump($ok) unless $ok eq "+OK\r\n";  
 }  
161    
162  sub _sock_send {          my @list = ( 0 .. $size );
163          my $self = shift;          foreach ( 0 .. $size ) {
164          warn "## _sock_send ",dump( @_ );                  $list[ $_ ] = __sock_read_bulk( substr(<$sock>,1,-2) );
165          print $sock join(' ',@_) . "\r\n";          }
         _sock_result();  
 }  
166    
167  sub _sock_send_ok {          warn "## list = ", dump( @list ) if $debug;
168          my $self = shift;          return @list;
         warn "## _sock_send_ok ",dump( @_ );  
         print $sock join(' ',@_) . "\r\n";  
         _sock_ok();  
169  }  }
170    
171  sub _sock_send_bulk {  1;
         my ( $self, $command, $key, $value ) = @_;  
         print $sock "$command $key " . length($value) . "\r\n$value\r\n";  
         _sock_ok();  
 }  
172    
173    __END__
174    
175  =head1 Connection Handling  =head1 Connection Handling
176    
# Line 109  sub _sock_send_bulk { Line 178  sub _sock_send_bulk {
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    
197  =cut  =head2 mget
198    
199  sub get {    my @values = $r->mget( 'foo', 'bar', 'baz' );
         my $self = shift;  
         $self->_sock_result_bulk('GET', @_);  
 }  
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 ) = @_;  
         return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));  
 }  
   
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.
246    
247  =head2 rpush  =head2 rpush
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    
263  =cut  =head2 ltrim
264    
265  sub lrange {    my $ok = $r->ltrim( $key, $start, $end );
         my ( $self, $key, $start, $end ) = @_;  
         my $size = $self->_sock_send('LRANGE', $key, $start, $end);  
266    
267          confess $size unless $size > 0;  =head2 lindex
         $size--;  
268    
269          my @list = ( 0 .. $size );    $r->lindex( $key, $index );
         foreach ( 0 .. $size ) {  
                 $list[ $_ ] = _sock_read_bulk();  
         }  
270    
271          warn "## lrange $key $start $end = [$size] ", dump( @list );  =head2 lset
272          return @list;  
273  }    $r->lset( $key, $index, $value );
274    
275    =head2 lrem
276    
277      my $modified_count = $r->lrem( $key, $count, $value );
278    
279    =head2 lpop
280    
281      my $value = $r->lpop( $key );
282    
283    =head2 rpop
284    
285      my $value = $r->rpop( $key );
286    
287    =head1 Commands operating on sets
288    
289    =head2 sadd
290    
291      $r->sadd( $key, $member );
292    
293    =head2 srem
294    
295      $r->srem( $key, $member );
296    
297    =head2 scard
298    
299      my $elements = $r->scard( $key );
300    
301    =head2 sismember
302    
303      $r->sismember( $key, $member );
304    
305    =head2 sinter
306    
307      $r->sinter( $key1, $key2, ... );
308    
309    =head2 sinterstore
310    
311      my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
312    
313    =head1 Multiple databases handling commands
314    
315    =head2 select
316    
317      $r->select( $dbindex ); # 0 for new clients
318    
319    =head2 move
320    
321      $r->move( $key, $dbindex );
322    
323    =head2 flushdb
324    
325      $r->flushdb;
326    
327    =head2 flushall
328    
329      $r->flushall;
330    
331    =head1 Sorting
332    
333    =head2 sort
334    
335      $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
336    
337    =head1 Persistence control commands
338    
339    =head2 save
340    
341      $r->save;
342    
343    =head2 bgsave
344    
345      $r->bgsave;
346    
347    =head2 lastsave
348    
349      $r->lastsave;
350    
351    =head2 shutdown
352    
353      $r->shutdown;
354    
355    =head1 Remote server control commands
356    
357    =head2 info
358    
359      my $info_hash = $r->info;
360    
361  =head1 AUTHOR  =head1 AUTHOR
362    
# Line 333  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.21  
changed lines
  Added in v.53
  ViewVC Help
Powered by ViewVC 1.1.26