/[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

Annotation of /lib/Redis.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (hide annotations)
Fri Mar 19 14:38:13 2010 UTC (9 years, 5 months ago) by dpavlin
File size: 7353 byte(s)
added encoding notice
1 dpavlin 1 package Redis;
2    
3     use warnings;
4     use strict;
5    
6 dpavlin 2 use IO::Socket::INET;
7 dpavlin 63 use Data::Dumper;
8 dpavlin 5 use Carp qw/confess/;
9 dpavlin 70 use Encode;
10 dpavlin 2
11 dpavlin 1 =head1 NAME
12    
13 dpavlin 36 Redis - perl binding for Redis database
14 dpavlin 1
15     =cut
16    
17 dpavlin 66 our $VERSION = '1.2001';
18 dpavlin 1
19    
20 dpavlin 53 =head1 DESCRIPTION
21 dpavlin 1
22 dpavlin 2 Pure perl bindings for L<http://code.google.com/p/redis/>
23 dpavlin 1
24 dpavlin 66 This version supports protocol 1.2 or later of Redis available at
25 dpavlin 53
26 dpavlin 36 L<git://github.com/antirez/redis>
27    
28 dpavlin 53 This documentation
29     lists commands which are exercised in test suite, but
30     additinal commands will work correctly since protocol
31     specifies enough information to support almost all commands
32     with same peace of code with a little help of C<AUTOLOAD>.
33 dpavlin 1
34     =head1 FUNCTIONS
35    
36 dpavlin 2 =head2 new
37 dpavlin 1
38 dpavlin 61 my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379
39 dpavlin 53
40 dpavlin 61 my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );
41    
42 dpavlin 1 =cut
43    
44 dpavlin 2 sub new {
45     my $class = shift;
46 dpavlin 61 my $self = {@_};
47     $self->{debug} ||= $ENV{REDIS_DEBUG};
48 dpavlin 2
49 dpavlin 61 $self->{sock} = IO::Socket::INET->new(
50     PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
51 dpavlin 2 Proto => 'tcp',
52     ) || die $!;
53    
54 dpavlin 61 bless($self, $class);
55 dpavlin 2 $self;
56 dpavlin 1 }
57    
58 dpavlin 53 my $bulk_command = {
59     set => 1, setnx => 1,
60     rpush => 1, lpush => 1,
61     lset => 1, lrem => 1,
62     sadd => 1, srem => 1,
63     sismember => 1,
64     echo => 1,
65 dpavlin 65 getset => 1,
66     smove => 1,
67     zadd => 1,
68     zrem => 1,
69     zscore => 1,
70     zincrby => 1,
71     append => 1,
72 dpavlin 53 };
73    
74     # we don't want DESTROY to fallback into AUTOLOAD
75     sub DESTROY {}
76    
77     our $AUTOLOAD;
78     sub AUTOLOAD {
79     my $self = shift;
80    
81 dpavlin 69 use bytes;
82    
83 dpavlin 61 my $sock = $self->{sock} || die "no server connected";
84    
85 dpavlin 53 my $command = $AUTOLOAD;
86     $command =~ s/.*://;
87    
88 dpavlin 63 warn "## $command ",Dumper(@_) if $self->{debug};
89 dpavlin 53
90     my $send;
91    
92     if ( defined $bulk_command->{$command} ) {
93     my $value = pop;
94 dpavlin 55 $value = '' if ! defined $value;
95 dpavlin 53 $send
96     = uc($command)
97     . ' '
98     . join(' ', @_)
99     . ' '
100 dpavlin 55 . length( $value )
101 dpavlin 53 . "\r\n$value\r\n"
102     ;
103     } else {
104     $send
105     = uc($command)
106     . ' '
107     . join(' ', @_)
108     . "\r\n"
109     ;
110     }
111    
112 dpavlin 61 warn ">> $send" if $self->{debug};
113 dpavlin 53 print $sock $send;
114    
115     if ( $command eq 'quit' ) {
116     close( $sock ) || die "can't close socket: $!";
117     return 1;
118     }
119    
120     my $result = <$sock> || die "can't read socket: $!";
121 dpavlin 70 Encode::_utf8_on($result);
122 dpavlin 61 warn "<< $result" if $self->{debug};
123 dpavlin 53 my $type = substr($result,0,1);
124     $result = substr($result,1,-2);
125    
126     if ( $command eq 'info' ) {
127     my $hash;
128 dpavlin 61 foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
129 dpavlin 53 my ($n,$v) = split(/:/, $l, 2);
130     $hash->{$n} = $v;
131     }
132     return $hash;
133     } elsif ( $command eq 'keys' ) {
134 dpavlin 61 my $keys = $self->__read_bulk($result);
135 dpavlin 55 return split(/\s/, $keys) if $keys;
136     return;
137 dpavlin 53 }
138    
139     if ( $type eq '-' ) {
140 dpavlin 64 confess "[$command] $result";
141 dpavlin 53 } elsif ( $type eq '+' ) {
142     return $result;
143     } elsif ( $type eq '$' ) {
144 dpavlin 61 return $self->__read_bulk($result);
145 dpavlin 53 } elsif ( $type eq '*' ) {
146 dpavlin 61 return $self->__read_multi_bulk($result);
147 dpavlin 53 } elsif ( $type eq ':' ) {
148     return $result; # FIXME check if int?
149     } else {
150 dpavlin 61 confess "unknown type: $type", $self->__read_line();
151 dpavlin 53 }
152 dpavlin 11 }
153    
154 dpavlin 61 sub __read_bulk {
155     my ($self,$len) = @_;
156 dpavlin 53 return undef if $len < 0;
157    
158 dpavlin 12 my $v;
159 dpavlin 28 if ( $len > 0 ) {
160 dpavlin 61 read($self->{sock}, $v, $len) || die $!;
161 dpavlin 70 Encode::_utf8_on($v);
162 dpavlin 63 warn "<< ",Dumper($v),$/ if $self->{debug};
163 dpavlin 28 }
164 dpavlin 12 my $crlf;
165 dpavlin 61 read($self->{sock}, $crlf, 2); # skip cr/lf
166 dpavlin 12 return $v;
167     }
168    
169 dpavlin 61 sub __read_multi_bulk {
170     my ($self,$size) = @_;
171 dpavlin 53 return undef if $size < 0;
172 dpavlin 61 my $sock = $self->{sock};
173 dpavlin 21
174 dpavlin 33 $size--;
175    
176     my @list = ( 0 .. $size );
177     foreach ( 0 .. $size ) {
178 dpavlin 61 $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
179 dpavlin 33 }
180    
181 dpavlin 63 warn "## list = ", Dumper( @list ) if $self->{debug};
182 dpavlin 33 return @list;
183     }
184    
185 dpavlin 53 1;
186 dpavlin 14
187 dpavlin 53 __END__
188 dpavlin 20
189 dpavlin 2 =head1 Connection Handling
190 dpavlin 1
191 dpavlin 2 =head2 quit
192    
193     $r->quit;
194    
195     =head2 ping
196    
197 dpavlin 3 $r->ping || die "no server?";
198 dpavlin 2
199 dpavlin 3 =head1 Commands operating on string values
200    
201     =head2 set
202    
203 dpavlin 53 $r->set( foo => 'bar' );
204 dpavlin 3
205 dpavlin 53 $r->setnx( foo => 42 );
206 dpavlin 3
207     =head2 get
208    
209     my $value = $r->get( 'foo' );
210    
211 dpavlin 45 =head2 mget
212    
213 dpavlin 53 my @values = $r->mget( 'foo', 'bar', 'baz' );
214 dpavlin 45
215 dpavlin 7 =head2 incr
216 dpavlin 4
217 dpavlin 7 $r->incr('counter');
218 dpavlin 4
219 dpavlin 53 $r->incrby('tripplets', 3);
220 dpavlin 7
221 dpavlin 8 =head2 decr
222    
223     $r->decr('counter');
224    
225 dpavlin 53 $r->decrby('tripplets', 3);
226 dpavlin 8
227 dpavlin 9 =head2 exists
228    
229     $r->exists( 'key' ) && print "got key!";
230    
231 dpavlin 10 =head2 del
232    
233     $r->del( 'key' ) || warn "key doesn't exist";
234    
235 dpavlin 11 =head2 type
236    
237     $r->type( 'key' ); # = string
238    
239 dpavlin 12 =head1 Commands operating on the key space
240    
241     =head2 keys
242    
243     my @keys = $r->keys( '*glob_pattern*' );
244    
245 dpavlin 13 =head2 randomkey
246    
247     my $key = $r->randomkey;
248    
249 dpavlin 14 =head2 rename
250    
251 dpavlin 15 my $ok = $r->rename( 'old-key', 'new-key', $new );
252 dpavlin 14
253 dpavlin 17 =head2 dbsize
254    
255     my $nr_keys = $r->dbsize;
256    
257 dpavlin 18 =head1 Commands operating on lists
258    
259 dpavlin 35 See also L<Redis::List> for tie interface.
260    
261 dpavlin 18 =head2 rpush
262    
263     $r->rpush( $key, $value );
264    
265 dpavlin 19 =head2 lpush
266    
267     $r->lpush( $key, $value );
268    
269 dpavlin 20 =head2 llen
270    
271     $r->llen( $key );
272    
273 dpavlin 21 =head2 lrange
274    
275     my @list = $r->lrange( $key, $start, $end );
276    
277 dpavlin 22 =head2 ltrim
278    
279     my $ok = $r->ltrim( $key, $start, $end );
280    
281 dpavlin 23 =head2 lindex
282    
283     $r->lindex( $key, $index );
284    
285 dpavlin 24 =head2 lset
286 dpavlin 23
287 dpavlin 24 $r->lset( $key, $index, $value );
288    
289 dpavlin 26 =head2 lrem
290    
291 dpavlin 27 my $modified_count = $r->lrem( $key, $count, $value );
292 dpavlin 26
293 dpavlin 27 =head2 lpop
294    
295     my $value = $r->lpop( $key );
296    
297     =head2 rpop
298    
299     my $value = $r->rpop( $key );
300    
301 dpavlin 30 =head1 Commands operating on sets
302    
303     =head2 sadd
304    
305     $r->sadd( $key, $member );
306    
307     =head2 srem
308    
309     $r->srem( $key, $member );
310    
311 dpavlin 31 =head2 scard
312    
313     my $elements = $r->scard( $key );
314    
315 dpavlin 32 =head2 sismember
316    
317     $r->sismember( $key, $member );
318    
319 dpavlin 33 =head2 sinter
320    
321     $r->sinter( $key1, $key2, ... );
322    
323 dpavlin 34 =head2 sinterstore
324    
325     my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
326    
327 dpavlin 38 =head1 Multiple databases handling commands
328    
329     =head2 select
330    
331 dpavlin 40 $r->select( $dbindex ); # 0 for new clients
332 dpavlin 38
333 dpavlin 40 =head2 move
334    
335     $r->move( $key, $dbindex );
336    
337 dpavlin 41 =head2 flushdb
338    
339     $r->flushdb;
340    
341     =head2 flushall
342    
343     $r->flushall;
344    
345 dpavlin 47 =head1 Sorting
346    
347 dpavlin 48 =head2 sort
348    
349 dpavlin 47 $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');
350    
351 dpavlin 48 =head1 Persistence control commands
352    
353     =head2 save
354    
355     $r->save;
356    
357 dpavlin 50 =head2 bgsave
358    
359     $r->bgsave;
360    
361     =head2 lastsave
362    
363     $r->lastsave;
364    
365     =head2 shutdown
366    
367     $r->shutdown;
368    
369 dpavlin 51 =head1 Remote server control commands
370    
371     =head2 info
372    
373     my $info_hash = $r->info;
374    
375 dpavlin 71 =head1 ENCODING
376    
377     Since Redis knows nothing about encoding, we are forcing utf-8 flag on all data received from Redis.
378     This change is introduced in 1.2001 version.
379    
380     This allows us to round-trip utf-8 encoded characters correctly, but might be problem if you push
381     binary junk into Redis and expect to get it back without utf-8 flag turned on.
382    
383 dpavlin 1 =head1 AUTHOR
384    
385     Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
386    
387     =head1 BUGS
388    
389     Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
390     the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
391     automatically be notified of progress on your bug as I make changes.
392    
393    
394    
395    
396     =head1 SUPPORT
397    
398     You can find documentation for this module with the perldoc command.
399    
400     perldoc Redis
401 dpavlin 53 perldoc Redis::List
402     perldoc Redis::Hash
403 dpavlin 1
404    
405     You can also look for information at:
406    
407     =over 4
408    
409     =item * RT: CPAN's request tracker
410    
411     L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
412    
413     =item * AnnoCPAN: Annotated CPAN documentation
414    
415     L<http://annocpan.org/dist/Redis>
416    
417     =item * CPAN Ratings
418    
419     L<http://cpanratings.perl.org/d/Redis>
420    
421     =item * Search CPAN
422    
423     L<http://search.cpan.org/dist/Redis>
424    
425     =back
426    
427    
428     =head1 ACKNOWLEDGEMENTS
429    
430    
431     =head1 COPYRIGHT & LICENSE
432    
433 dpavlin 66 Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
434 dpavlin 1
435     This program is free software; you can redistribute it and/or modify it
436     under the same terms as Perl itself.
437    
438    
439     =cut
440    
441     1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26