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