Redis.pre-github/lib/Redis.pm

package Redis;

use warnings;
use strict;

use IO::Socket::INET;
use Data::Dump qw/dump/;
use Carp qw/confess/;

=head1 NAME

Redis - perl binding for Redis database

=cut

our $VERSION = '0.0801';


=head1 DESCRIPTION

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

This version support git version 0.08 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,
};

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