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.08';


=head1 DESCRIPTION

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

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

=cut

our $debug = $ENV{REDIS} || 0;

our $sock;
my $server = '127.0.0.1:6379';

sub new {
        my $class = shift;
        my $self = {};
        bless($self, $class);

        warn "# opening socket to $server";

        $sock ||= IO::Socket::INET->new(
                PeerAddr => $server,
                Proto => 'tcp',
        ) || die $!;

        $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 $command = $AUTOLOAD;
        $command =~ s/.*://;

        warn "## $command ",dump(@_) if $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 $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 $debug;
        my $type = substr($result,0,1);
        $result = substr($result,1,-2);

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

        if ( $type eq '-' ) {
                confess $result;
        } elsif ( $type eq '+' ) {
                return $result;
        } elsif ( $type eq '$' ) {
                return __sock_read_bulk($result);
        } elsif ( $type eq '*' ) {
                return __sock_read_multi_bulk($result);
        } elsif ( $type eq ':' ) {
                return $result; # FIXME check if int?
        } else {
                confess "unknown type: $type", __sock_read_line();
        }
}

sub __sock_read_bulk {
        my $len = shift;
        return undef if $len < 0;

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

sub __sock_read_multi_bulk {
        my $size = shift;
        return undef if $size < 0;

        $size--;

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

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