/[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 55 - (show annotations)
Tue Mar 24 23:43:24 2009 UTC (15 years ago) by dpavlin
File size: 6574 byte(s)
fix warnings
1 package Redis;
2
3 use warnings;
4 use strict;
5
6 use IO::Socket::INET;
7 use Data::Dump qw/dump/;
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.08';
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 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;
38
39 =cut
40
41 our $debug = $ENV{REDIS} || 0;
42
43 our $sock;
44 my $server = '127.0.0.1:6379';
45
46 sub new {
47 my $class = shift;
48 my $self = {};
49 bless($self, $class);
50
51 warn "# opening socket to $server";
52
53 $sock ||= IO::Socket::INET->new(
54 PeerAddr => $server,
55 Proto => 'tcp',
56 ) || die $!;
57
58 $self;
59 }
60
61 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 # we don't want DESTROY to fallback into AUTOLOAD
71 sub DESTROY {}
72
73 our $AUTOLOAD;
74 sub AUTOLOAD {
75 my $self = shift;
76
77 my $command = $AUTOLOAD;
78 $command =~ s/.*://;
79
80 warn "## $command ",dump(@_) if $debug;
81
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 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 sub __sock_read_bulk {
146 my $len = shift;
147 return undef if $len < 0;
148
149 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 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 warn "## list = ", dump( @list ) if $debug;
171 return @list;
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
189
190 =head2 set
191
192 $r->set( foo => 'bar' );
193
194 $r->setnx( foo => 42 );
195
196 =head2 get
197
198 my $value = $r->get( 'foo' );
199
200 =head2 mget
201
202 my @values = $r->mget( 'foo', 'bar', 'baz' );
203
204 =head2 incr
205
206 $r->incr('counter');
207
208 $r->incrby('tripplets', 3);
209
210 =head2 decr
211
212 $r->decr('counter');
213
214 $r->decrby('tripplets', 3);
215
216 =head2 exists
217
218 $r->exists( 'key' ) && print "got key!";
219
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
365
366 Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
367
368 =head1 BUGS
369
370 Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
371 the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
372 automatically be notified of progress on your bug as I make changes.
373
374
375
376
377 =head1 SUPPORT
378
379 You can find documentation for this module with the perldoc command.
380
381 perldoc Redis
382 perldoc Redis::List
383 perldoc Redis::Hash
384
385
386 You can also look for information at:
387
388 =over 4
389
390 =item * RT: CPAN's request tracker
391
392 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
393
394 =item * AnnoCPAN: Annotated CPAN documentation
395
396 L<http://annocpan.org/dist/Redis>
397
398 =item * CPAN Ratings
399
400 L<http://cpanratings.perl.org/d/Redis>
401
402 =item * Search CPAN
403
404 L<http://search.cpan.org/dist/Redis>
405
406 =back
407
408
409 =head1 ACKNOWLEDGEMENTS
410
411
412 =head1 COPYRIGHT & LICENSE
413
414 Copyright 2009 Dobrica Pavlinusic, all rights reserved.
415
416 This program is free software; you can redistribute it and/or modify it
417 under the same terms as Perl itself.
418
419
420 =cut
421
422 1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26