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