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;
                $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' ) {
                return split(/\s/, __sock_read_bulk($result));
        }

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