Redis.pre-github/lib/Redis.pm

package Redis;

use warnings;
use strict;

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

=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: $!";
        Encode::_utf8_on($result);
        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 $!;
                Encode::_utf8_on($v);
                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 ENCODING

Since Redis knows nothing about encoding, we are forcing utf-8 flag on all data received from Redis.
This change is introduced in 1.2001 version.

This allows us to round-trip utf-8 encoded characters correctly, but might be problem if you push
binary junk into Redis and expect to get it back without utf-8 flag turned on.

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