Redis.pre-github/lib/Redis.pm

package Redis;

use warnings;
use strict;

use IO::Socket::INET;
use Data::Dumper;
use Carp qw/confess/;

=head1 NAME

Redis - perl binding for Redis database

=cut

our $VERSION = '1.2001';


=head1 DESCRIPTION

Pure perl bindings for L<http://code.google.com/p/redis/>

This version supports protocol 1.2 or later of Redis available at

L<git://github.com/antirez/redis>

This documentation
lists commands which are exercised in test suite, but
additinal commands will work correctly since protocol
specifies enough information to support almost all commands
with same peace of code with a little help of C<AUTOLOAD>.

=head1 FUNCTIONS

=head2 new

  my $r = Redis->new; # $ENV{REDIS_SERVER} or 127.0.0.1:6379

  my $r = Redis->new( server => '192.168.0.1:6379', debug = 0 );

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        $self->{debug} ||= $ENV{REDIS_DEBUG};

        $self->{sock} = IO::Socket::INET->new(
                PeerAddr => $self->{server} || $ENV{REDIS_SERVER} || '127.0.0.1:6379',
                Proto => 'tcp',
        ) || die $!;

        bless($self, $class);
        $self;
}

my $bulk_command = {
        set => 1,       setnx => 1,
        rpush => 1,     lpush => 1,
        lset => 1,      lrem => 1,
        sadd => 1,      srem => 1,
        sismember => 1,
        echo => 1,
        getset => 1,
        smove => 1,
        zadd => 1,
        zrem => 1,
        zscore => 1,
        zincrby => 1,
        append => 1,
};

# we don't want DESTROY to fallback into AUTOLOAD
sub DESTROY {}

our $AUTOLOAD;
sub AUTOLOAD {
        my $self = shift;

        my $sock = $self->{sock} || die "no server connected";

        my $command = $AUTOLOAD;
        $command =~ s/.*://;

        warn "## $command ",Dumper(@_) if $self->{debug};

        my $send;

        if ( defined $bulk_command->{$command} ) {
                my $value = pop;
                $value = '' if ! defined $value;
                $send
                        = uc($command)
                        . ' '
                        . join(' ', @_)
                        . ' ' 
                        . length( $value )
                        . "\r\n$value\r\n"
                        ;
        } else {
                $send
                        = uc($command)
                        . ' '
                        . join(' ', @_)
                        . "\r\n"
                        ;
        }

        warn ">> $send" if $self->{debug};
        print $sock $send;

        if ( $command eq 'quit' ) {
                close( $sock ) || die "can't close socket: $!";
                return 1;
        }

        my $result = <$sock> || die "can't read socket: $!";
        warn "<< $result" if $self->{debug};
        my $type = substr($result,0,1);
        $result = substr($result,1,-2);

        if ( $command eq 'info' ) {
                my $hash;
                foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
                        my ($n,$v) = split(/:/, $l, 2);
                        $hash->{$n} = $v;
                }
                return $hash;
        } elsif ( $command eq 'keys' ) {
                my $keys = $self->__read_bulk($result);
                return split(/\s/, $keys) if $keys;
                return;
        }

        if ( $type eq '-' ) {
                confess "[$command] $result";
        } elsif ( $type eq '+' ) {
                return $result;
        } elsif ( $type eq '$' ) {
                return $self->__read_bulk($result);
        } elsif ( $type eq '*' ) {
                return $self->__read_multi_bulk($result);
        } elsif ( $type eq ':' ) {
                return $result; # FIXME check if int?
        } else {
                confess "unknown type: $type", $self->__read_line();
        }
}

sub __read_bulk {
        my ($self,$len) = @_;
        return undef if $len < 0;

        my $v;
        if ( $len > 0 ) {
                read($self->{sock}, $v, $len) || die $!;
                warn "<< ",Dumper($v),$/ if $self->{debug};
        }
        my $crlf;
        read($self->{sock}, $crlf, 2); # skip cr/lf
        return $v;
}

sub __read_multi_bulk {
        my ($self,$size) = @_;
        return undef if $size < 0;
        my $sock = $self->{sock};

        $size--;

        my @list = ( 0 .. $size );
        foreach ( 0 .. $size ) {
                $list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
        }

        warn "## list = ", Dumper( @list ) if $self->{debug};
        return @list;
}

1;

__END__

=head1 Connection Handling

=head2 quit

  $r->quit;

=head2 ping

  $r->ping || die "no server?";

=head1 Commands operating on string values

=head2 set

  $r->set( foo => 'bar' );

  $r->setnx( foo => 42 );

=head2 get

  my $value = $r->get( 'foo' );

=head2 mget

  my @values = $r->mget( 'foo', 'bar', 'baz' );

=head2 incr

  $r->incr('counter');

  $r->incrby('tripplets', 3);

=head2 decr

  $r->decr('counter');

  $r->decrby('tripplets', 3);

=head2 exists

  $r->exists( 'key' ) && print "got key!";

=head2 del

  $r->del( 'key' ) || warn "key doesn't exist";

=head2 type

  $r->type( 'key' ); # = string

=head1 Commands operating on the key space

=head2 keys

  my @keys = $r->keys( '*glob_pattern*' );

=head2 randomkey

  my $key = $r->randomkey;

=head2 rename

  my $ok = $r->rename( 'old-key', 'new-key', $new );

=head2 dbsize

  my $nr_keys = $r->dbsize;

=head1 Commands operating on lists

See also L<Redis::List> for tie interface.

=head2 rpush

  $r->rpush( $key, $value );

=head2 lpush

  $r->lpush( $key, $value );

=head2 llen

  $r->llen( $key );

=head2 lrange

  my @list = $r->lrange( $key, $start, $end );

=head2 ltrim

  my $ok = $r->ltrim( $key, $start, $end );

=head2 lindex

  $r->lindex( $key, $index );

=head2 lset

  $r->lset( $key, $index, $value );

=head2 lrem

  my $modified_count = $r->lrem( $key, $count, $value );

=head2 lpop

  my $value = $r->lpop( $key );

=head2 rpop

  my $value = $r->rpop( $key );

=head1 Commands operating on sets

=head2 sadd

  $r->sadd( $key, $member );

=head2 srem

  $r->srem( $key, $member );

=head2 scard

  my $elements = $r->scard( $key );

=head2 sismember

  $r->sismember( $key, $member );

=head2 sinter

  $r->sinter( $key1, $key2, ... );

=head2 sinterstore

  my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );

=head1 Multiple databases handling commands

=head2 select

  $r->select( $dbindex ); # 0 for new clients

=head2 move

  $r->move( $key, $dbindex );

=head2 flushdb

  $r->flushdb;

=head2 flushall

  $r->flushall;

=head1 Sorting

=head2 sort

  $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA');

=head1 Persistence control commands

=head2 save

  $r->save;

=head2 bgsave

  $r->bgsave;

=head2 lastsave

  $r->lastsave;

=head2 shutdown

  $r->shutdown;

=head1 Remote server control commands

=head2 info

  my $info_hash = $r->info;

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Redis
        perldoc Redis::List
        perldoc Redis::Hash


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Redis>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Redis>

=item * Search CPAN

L<http://search.cpan.org/dist/Redis>

=back


=head1 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

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