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

Contents of /lib/Redis.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (show annotations)
Thu Dec 3 18:36:56 2009 UTC (9 years, 7 months ago) by dpavlin
File size: 6838 byte(s)
confess command and result

1 package Redis;
2
3 use warnings;
4 use strict;
5
6 use IO::Socket::INET;
7 use Data::Dumper;
8 use Carp qw/confess/;
9
10 =head1 NAME
11
12 Redis - perl binding for Redis database
13
14 =cut
15
16 our $VERSION = '0.0801';
17
18
19 =head1 DESCRIPTION
20
21 Pure perl bindings for L<http://code.google.com/p/redis/>
22
23 This version support git version 0.08 or later of Redis available at
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
34
35 =head2 new
36
37 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 =cut
42
43 sub new {
44 my $class = shift;
45 my $self = {@_};
46 $self->{debug} ||= $ENV{REDIS_DEBUG};
47
48 $self->{sock} = IO::Socket::INET->new(
49 PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
50 Proto => 'tcp',
51 ) || die $!;
52
53 bless($self, $class);
54 $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 ",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 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 "[$command] $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 "<< ",Dumper($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 = ", Dumper( @list ) if $self->{debug};
170 return @list;
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
188
189 =head2 set
190
191 $r->set( foo => 'bar' );
192
193 $r->setnx( foo => 42 );
194
195 =head2 get
196
197 my $value = $r->get( 'foo' );
198
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
364
365 Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
366
367 =head1 BUGS
368
369 Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
370 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
371 automatically be notified of progress on your bug as I make changes.
372
373
374
375
376 =head1 SUPPORT
377
378 You can find documentation for this module with the perldoc command.
379
380 perldoc Redis
381 perldoc Redis::List
382 perldoc Redis::Hash
383
384
385 You can also look for information at:
386
387 =over 4
388
389 =item * RT: CPAN's request tracker
390
391 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
392
393 =item * AnnoCPAN: Annotated CPAN documentation
394
395 L<http://annocpan.org/dist/Redis>
396
397 =item * CPAN Ratings
398
399 L<http://cpanratings.perl.org/d/Redis>
400
401 =item * Search CPAN
402
403 L<http://search.cpan.org/dist/Redis>
404
405 =back
406
407
408 =head1 ACKNOWLEDGEMENTS
409
410
411 =head1 COPYRIGHT & LICENSE
412
413 Copyright 2009 Dobrica Pavlinusic, all rights reserved.
414
415 This program is free software; you can redistribute it and/or modify it
416 under the same terms as Perl itself.
417
418
419 =cut
420
421 1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26