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;

        use bytes;

        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	69	use bytes;
81
82	dpavlin	61	my $sock = $self->{sock} \|\| die "no server connected";
83
84	dpavlin	53	my $command = $AUTOLOAD;
85			$command =~ s/.*://;
86
87	dpavlin	63	warn "## $command ",Dumper(@_) if $self->{debug};
88	dpavlin	53
89			my $send;
90
91			if ( defined $bulk_command->{$command} ) {
92			my $value = pop;
93	dpavlin	55	$value = '' if ! defined $value;
94	dpavlin	53	$send
95			= uc($command)
96			. ' '
97			. join(' ', @_)
98			. ' '
99	dpavlin	55	. length( $value )
100	dpavlin	53	. "\r\n$value\r\n"
101			;
102			} else {
103			$send
104			= uc($command)
105			. ' '
106			. join(' ', @_)
107			. "\r\n"
108			;
109			}
110
111	dpavlin	61	warn ">> $send" if $self->{debug};
112	dpavlin	53	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	dpavlin	61	warn "<< $result" if $self->{debug};
121	dpavlin	53	my $type = substr($result,0,1);
122			$result = substr($result,1,-2);
123
124			if ( $command eq 'info' ) {
125			my $hash;
126	dpavlin	61	foreach my $l ( split(/\r\n/, $self->__read_bulk($result) ) ) {
127	dpavlin	53	my ($n,$v) = split(/:/, $l, 2);
128			$hash->{$n} = $v;
129			}
130			return $hash;
131			} elsif ( $command eq 'keys' ) {
132	dpavlin	61	my $keys = $self->__read_bulk($result);
133	dpavlin	55	return split(/\s/, $keys) if $keys;
134			return;
135	dpavlin	53	}
136
137			if ( $type eq '-' ) {
138	dpavlin	64	confess "[$command] $result";
139	dpavlin	53	} elsif ( $type eq '+' ) {
140			return $result;
141			} elsif ( $type eq '$' ) {
142	dpavlin	61	return $self->__read_bulk($result);
143	dpavlin	53	} elsif ( $type eq '*' ) {
144	dpavlin	61	return $self->__read_multi_bulk($result);
145	dpavlin	53	} elsif ( $type eq ':' ) {
146			return $result; # FIXME check if int?
147			} else {
148	dpavlin	61	confess "unknown type: $type", $self->__read_line();
149	dpavlin	53	}
150	dpavlin	11	}
151
152	dpavlin	61	sub __read_bulk {
153			my ($self,$len) = @_;
154	dpavlin	53	return undef if $len < 0;
155
156	dpavlin	12	my $v;
157	dpavlin	28	if ( $len > 0 ) {
158	dpavlin	61	read($self->{sock}, $v, $len) \|\| die $!;
159	dpavlin	63	warn "<< ",Dumper($v),$/ if $self->{debug};
160	dpavlin	28	}
161	dpavlin	12	my $crlf;
162	dpavlin	61	read($self->{sock}, $crlf, 2); # skip cr/lf
163	dpavlin	12	return $v;
164			}
165
166	dpavlin	61	sub __read_multi_bulk {
167			my ($self,$size) = @_;
168	dpavlin	53	return undef if $size < 0;
169	dpavlin	61	my $sock = $self->{sock};
170	dpavlin	21
171	dpavlin	33	$size--;
172
173			my @list = ( 0 .. $size );
174			foreach ( 0 .. $size ) {
175	dpavlin	61	$list[ $_ ] = $self->__read_bulk( substr(<$sock>,1,-2) );
176	dpavlin	33	}
177
178	dpavlin	63	warn "## list = ", Dumper( @list ) if $self->{debug};
179	dpavlin	33	return @list;
180			}
181
182	dpavlin	53	1;
183	dpavlin	14
184	dpavlin	53	__END__
185	dpavlin	20
186	dpavlin	2	=head1 Connection Handling
187	dpavlin	1
188	dpavlin	2	=head2 quit
189
190			$r->quit;
191
192			=head2 ping
193
194	dpavlin	3	$r->ping \|\| die "no server?";
195	dpavlin	2
196	dpavlin	3	=head1 Commands operating on string values
197
198			=head2 set
199
200	dpavlin	53	$r->set( foo => 'bar' );
201	dpavlin	3
202	dpavlin	53	$r->setnx( foo => 42 );
203	dpavlin	3
204			=head2 get
205
206			my $value = $r->get( 'foo' );
207
208	dpavlin	45	=head2 mget
209
210	dpavlin	53	my @values = $r->mget( 'foo', 'bar', 'baz' );
211	dpavlin	45
212	dpavlin	7	=head2 incr
213	dpavlin	4
214	dpavlin	7	$r->incr('counter');
215	dpavlin	4
216	dpavlin	53	$r->incrby('tripplets', 3);
217	dpavlin	7
218	dpavlin	8	=head2 decr
219
220			$r->decr('counter');
221
222	dpavlin	53	$r->decrby('tripplets', 3);
223	dpavlin	8
224	dpavlin	9	=head2 exists
225
226			$r->exists( 'key' ) && print "got key!";
227
228	dpavlin	10	=head2 del
229
230			$r->del( 'key' ) \|\| warn "key doesn't exist";
231
232	dpavlin	11	=head2 type
233
234			$r->type( 'key' ); # = string
235
236	dpavlin	12	=head1 Commands operating on the key space
237
238			=head2 keys
239
240			my @keys = $r->keys( 'glob_pattern' );
241
242	dpavlin	13	=head2 randomkey
243
244			my $key = $r->randomkey;
245
246	dpavlin	14	=head2 rename
247
248	dpavlin	15	my $ok = $r->rename( 'old-key', 'new-key', $new );
249	dpavlin	14
250	dpavlin	17	=head2 dbsize
251
252			my $nr_keys = $r->dbsize;
253
254	dpavlin	18	=head1 Commands operating on lists
255
256	dpavlin	35	See also L<Redis::List> for tie interface.
257
258	dpavlin	18	=head2 rpush
259
260			$r->rpush( $key, $value );
261
262	dpavlin	19	=head2 lpush
263
264			$r->lpush( $key, $value );
265
266	dpavlin	20	=head2 llen
267
268			$r->llen( $key );
269
270	dpavlin	21	=head2 lrange
271
272			my @list = $r->lrange( $key, $start, $end );
273
274	dpavlin	22	=head2 ltrim
275
276			my $ok = $r->ltrim( $key, $start, $end );
277
278	dpavlin	23	=head2 lindex
279
280			$r->lindex( $key, $index );
281
282	dpavlin	24	=head2 lset
283	dpavlin	23
284	dpavlin	24	$r->lset( $key, $index, $value );
285
286	dpavlin	26	=head2 lrem
287
288	dpavlin	27	my $modified_count = $r->lrem( $key, $count, $value );
289	dpavlin	26
290	dpavlin	27	=head2 lpop
291
292			my $value = $r->lpop( $key );
293
294			=head2 rpop
295
296			my $value = $r->rpop( $key );
297
298	dpavlin	30	=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	dpavlin	31	=head2 scard
309
310			my $elements = $r->scard( $key );
311
312	dpavlin	32	=head2 sismember
313
314			$r->sismember( $key, $member );
315
316	dpavlin	33	=head2 sinter
317
318			$r->sinter( $key1, $key2, ... );
319
320	dpavlin	34	=head2 sinterstore
321
322			my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... );
323
324	dpavlin	38	=head1 Multiple databases handling commands
325
326			=head2 select
327
328	dpavlin	40	$r->select( $dbindex ); # 0 for new clients
329	dpavlin	38
330	dpavlin	40	=head2 move
331
332			$r->move( $key, $dbindex );
333
334	dpavlin	41	=head2 flushdb
335
336			$r->flushdb;
337
338			=head2 flushall
339
340			$r->flushall;
341
342	dpavlin	47	=head1 Sorting
343
344	dpavlin	48	=head2 sort
345
346	dpavlin	47	$r->sort("key BY pattern LIMIT start end GET pattern ASC\|DESC ALPHA');
347
348	dpavlin	48	=head1 Persistence control commands
349
350			=head2 save
351
352			$r->save;
353
354	dpavlin	50	=head2 bgsave
355
356			$r->bgsave;
357
358			=head2 lastsave
359
360			$r->lastsave;
361
362			=head2 shutdown
363
364			$r->shutdown;
365
366	dpavlin	51	=head1 Remote server control commands
367
368			=head2 info
369
370			my $info_hash = $r->info;
371
372	dpavlin	1	=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	dpavlin	53	perldoc Redis::List
391			perldoc Redis::Hash
392	dpavlin	1
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	dpavlin	66	Copyright 2009-2010 Dobrica Pavlinusic, all rights reserved.
423	dpavlin	1
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