/[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 69 - (show annotations)
Wed Mar 17 18:22:09 2010 UTC (14 years ago) by dpavlin
File size: 6947 byte(s)
added use bytes to support utf-8 encoded strings

We are not round-tripping utf-8 encoding strings correctly in
this version. We will get string back wothout perl utf-8 flag

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

  ViewVC Help
Powered by ViewVC 1.1.26