/[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 2 by dpavlin, Sat Mar 21 21:25:52 2009 UTC revision 61 by dpavlin, Sat Sep 12 15:08:59 2009 UTC
# Line 5  use strict; Line 5  use strict;
5    
6  use IO::Socket::INET;  use IO::Socket::INET;
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8    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      my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
40    
41  our $sock;  =cut
 my $server = '127.0.0.1:6379';  
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};
47    
48          warn "# opening socket to $server";          $self->{sock} = IO::Socket::INET->new(
49                    PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
         $sock ||= IO::Socket::INET->new(  
                 PeerAddr => $server,  
50                  Proto => 'tcp',                  Proto => 'tcp',
51          ) || die $!;          ) || die $!;
52    
53            bless($self, $class);
54          $self;          $self;
55  }  }
56    
57    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    # 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 __read_bulk {
144            my ($self,$len) = @_;
145            return undef if $len < 0;
146    
147            my $v;
148            if ( $len > 0 ) {
149                    read($self->{sock}, $v, $len) || die $!;
150                    warn "<< ",dump($v),$/ if $self->{debug};
151            }
152            my $crlf;
153            read($self->{sock}, $crlf, 2); # skip cr/lf
154            return $v;
155    }
156    
157    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            warn "## list = ", dump( @list ) if $self->{debug};
170            return @list;
171    }
172    
173    1;
174    
175    __END__
176    
177  =head1 Connection Handling  =head1 Connection Handling
178    
179  =head2 quit  =head2 quit
180    
181    $r->quit;    $r->quit;
182    
183  =cut  =head2 ping
184    
185  sub quit {    $r->ping || die "no server?";
         my $self = shift;  
186    
187          close( $sock ) || warn $!;  =head1 Commands operating on string values
 }  
188    
189  =head2 ping  =head2 set
190    
191          $r->ping || die "no server?";    $r->set( foo => 'bar' );
192    
193  =cut    $r->setnx( foo => 42 );
194    
195  sub ping {  =head2 get
196          print $sock "PING\r\n";  
197          my $pong = <$sock>;    my $value = $r->get( 'foo' );
198          die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";  
199  }  =head2 mget
200    
201      my @values = $r->mget( 'foo', 'bar', 'baz' );
202    
203    =head2 incr
204    
205      $r->incr('counter');
206    
207      $r->incrby('tripplets', 3);
208    
209    =head2 decr
210    
211      $r->decr('counter');
212    
213      $r->decrby('tripplets', 3);
214    
215    =head2 exists
216    
217      $r->exists( 'key' ) && print "got key!";
218    
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 94  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.2  
changed lines
  Added in v.61
  ViewVC Help
Powered by ViewVC 1.1.26