/[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 7 by dpavlin, Sat Mar 21 22:38:56 2009 UTC revision 63 by dpavlin, Mon Sep 14 11:37:25 2009 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
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  =head1 Connection Handling  my $bulk_command = {
58            set => 1,       setnx => 1,
59            rpush => 1,     lpush => 1,
60            lset => 1,      lrem => 1,
61            sadd => 1,      srem => 1,
62            sismember => 1,
63            echo => 1,
64    };
65    
66  =head2 quit  # we don't want DESTROY to fallback into AUTOLOAD
67    sub DESTROY {}
68    
69    $r->quit;  our $AUTOLOAD;
70    sub AUTOLOAD {
71            my $self = shift;
72    
73  =cut          my $sock = $self->{sock} || die "no server connected";
74    
75  sub quit {          my $command = $AUTOLOAD;
76          my $self = shift;          $command =~ s/.*://;
77    
78            warn "## $command ",Dumper(@_) 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          close( $sock ) || warn $!;          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  =head2 ping  sub __read_bulk {
144            my ($self,$len) = @_;
145            return undef if $len < 0;
146    
147    $r->ping || die "no server?";          my $v;
148            if ( $len > 0 ) {
149                    read($self->{sock}, $v, $len) || die $!;
150                    warn "<< ",Dumper($v),$/ if $self->{debug};
151            }
152            my $crlf;
153            read($self->{sock}, $crlf, 2); # skip cr/lf
154            return $v;
155    }
156    
157  =cut  sub __read_multi_bulk {
158            my ($self,$size) = @_;
159            return undef if $size < 0;
160            my $sock = $self->{sock};
161    
162            $size--;
163    
164            my @list = ( 0 .. $size );
165            foreach ( 0 .. $size ) {
166                    $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
167            }
168    
169  sub ping {          warn "## list = ", Dumper( @list ) if $self->{debug};
170          print $sock "PING\r\n";          return @list;
         my $pong = <$sock>;  
         die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";  
171  }  }
172    
173    1;
174    
175    __END__
176    
177    =head1 Connection Handling
178    
179    =head2 quit
180    
181      $r->quit;
182    
183    =head2 ping
184    
185      $r->ping || die "no server?";
186    
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' );
192    
193  =cut    $r->setnx( foo => 42 );
   
 sub set {  
         my ( $self, $k, $v, $new ) = @_;  
         print $sock ( $new ? "SETNX" : "SET" ) . " $k " . length($v) . "\r\n$v\r\n";  
         my $ok = <$sock>;  
         confess dump($ok) unless $ok eq "+OK\r\n";  
 }  
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, $k ) = @_;  
         print $sock "GET $k\r\n";  
         my $len = <$sock>;  
 #       warn "# len: ",dump($len);  
         return undef if $len eq "nil\r\n";  
         my $v;  
         read($sock, $v, $len) || die $!;  
 #       warn "# v: ",dump($v);  
         my $crlf;  
         read($sock, $crlf, 2); # skip cr/lf  
         return $v;  
 }  
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);
208    
209  sub incr {  =head2 decr
210          my ( $self, $key, $value ) = @_;  
211          if ( defined $value ) {    $r->decr('counter');
212                  print $sock "INCRBY $key $value\r\n";  
213          } else {    $r->decrby('tripplets', 3);
214                  print $sock "INCR $key\r\n";  
215          }  =head2 exists
216          my $count = <$sock>;  
217          warn "# $key = $count";    $r->exists( 'key' ) && print "got key!";
218          return $count;  
219  }  =head2 del
220    
221      $r->del( 'key' ) || warn "key doesn't exist";
222    
223    =head2 type
224    
225      $r->type( 'key' ); # = string
226    
227    =head1 Commands operating on the key space
228    
229    =head2 keys
230    
231      my @keys = $r->keys( '*glob_pattern*' );
232    
233    =head2 randomkey
234    
235      my $key = $r->randomkey;
236    
237    =head2 rename
238    
239      my $ok = $r->rename( 'old-key', 'new-key', $new );
240    
241    =head2 dbsize
242    
243      my $nr_keys = $r->dbsize;
244    
245    =head1 Commands operating on lists
246    
247    See also L<Redis::List> for tie interface.
248    
249    =head2 rpush
250    
251      $r->rpush( $key, $value );
252    
253    =head2 lpush
254    
255      $r->lpush( $key, $value );
256    
257    =head2 llen
258    
259      $r->llen( $key );
260    
261    =head2 lrange
262    
263      my @list = $r->lrange( $key, $start, $end );
264    
265    =head2 ltrim
266    
267      my $ok = $r->ltrim( $key, $start, $end );
268    
269    =head2 lindex
270    
271      $r->lindex( $key, $index );
272    
273    =head2 lset
274    
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 149  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.7  
changed lines
  Added in v.63
  ViewVC Help
Powered by ViewVC 1.1.26