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