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 - The great new Redis!

=cut

our $VERSION = '0.01';


=head1 SYNOPSIS

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

    use Redis;

    my $r = Redis->new();


=head1 FUNCTIONS

=head2 new

=cut

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;
}

sub _sock_result {
        my $result = <$sock>;
        warn "# result: ",dump( $result );
        $result =~ s{\r\n$}{} || warn "can't find cr/lf";
        return $result;
}

sub _sock_read_bulk {
        my $len = <$sock>;
        warn "## bulk len: ",dump($len);
        return undef if $len eq "nil\r\n";
        my $v;
        read($sock, $v, $len) || die $!;
        warn "## bulk v: ",dump($v);
        my $crlf;
        read($sock, $crlf, 2); # skip cr/lf
        return $v;
}

sub _sock_result_bulk {
        my $self = shift;
        warn "## _sock_result_bulk ",dump( @_ );
        print $sock join(' ',@_) . "\r\n";
        _sock_read_bulk();
}

sub _sock_ok {
        my $ok = <$sock>;
        confess dump($ok) unless $ok eq "+OK\r\n";
}

sub _sock_send {
        my $self = shift;
        warn "## _sock_send ",dump( @_ );
        print $sock join(' ',@_) . "\r\n";
        _sock_result();
}

sub _sock_send_ok {
        my $self = shift;
        warn "## _sock_send_ok ",dump( @_ );
        print $sock join(' ',@_) . "\r\n";
        _sock_ok();
}

sub _sock_send_bulk {
        my $self = shift;
        my $value = pop;
        print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n";
        _sock_ok();
}


=head1 Connection Handling

=head2 quit

  $r->quit;

=cut

sub quit {
        my $self = shift;

        close( $sock ) || warn $!;
}

=head2 ping

  $r->ping || die "no server?";

=cut

sub ping {
        print $sock "PING\r\n";
        my $pong = <$sock>;
        die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
}

=head1 Commands operating on string values

=head2 set

  $r->set( foo => 'bar', $new );

=cut

sub set {
        my ( $self, $key, $value, $new ) = @_;
        $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
}

=head2 get

  my $value = $r->get( 'foo' );

=cut

sub get {
        my $self = shift;
        $self->_sock_result_bulk('GET', @_);
}

=head2 incr

  $r->incr('counter');
  $r->incr('tripplets', 3);

=cut

        
sub incr {
        my $self = shift;
        $self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
}

=head2 decr

  $r->decr('counter');
  $r->decr('tripplets', 3);

=cut

sub decr {
        my $self = shift;
        $self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
}

=head2 exists

  $r->exists( 'key' ) && print "got key!";

=cut

sub exists {
        my ( $self, $key ) = @_;
        $self->_sock_send( 'EXISTS', $key );
}

=head2 del

  $r->del( 'key' ) || warn "key doesn't exist";

=cut

sub del {
        my ( $self, $key ) = @_;
        $self->_sock_send( 'DEL', $key );
}

=head2 type

  $r->type( 'key' ); # = string

=cut

sub type {
        my ( $self, $key ) = @_;
        $self->_sock_send( 'TYPE', $key );
}

=head1 Commands operating on the key space

=head2 keys

  my @keys = $r->keys( '*glob_pattern*' );

=cut

sub keys {
        my ( $self, $glob ) = @_;
        return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
}

=head2 randomkey

  my $key = $r->randomkey;

=cut

sub randomkey {
        my ( $self ) = @_;
        $self->_sock_send( 'RANDOMKEY' );
}

=head2 rename

  my $ok = $r->rename( 'old-key', 'new-key', $new );

=cut

sub rename {
        my ( $self, $old, $new, $nx ) = @_;
        $self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
}

=head2 dbsize

  my $nr_keys = $r->dbsize;

=cut

sub dbsize {
        my ( $self ) = @_;
        $self->_sock_send('DBSIZE');
}

=head1 Commands operating on lists

=head2 rpush

  $r->rpush( $key, $value );

=cut

sub rpush {
        my ( $self, $key, $value ) = @_;
        $self->_sock_send_bulk('RPUSH', $key, $value);
}

=head2 lpush

  $r->lpush( $key, $value );

=cut

sub lpush {
        my ( $self, $key, $value ) = @_;
        $self->_sock_send_bulk('LPUSH', $key, $value);
}

=head2 llen

  $r->llen( $key );

=cut

sub llen {
        my ( $self, $key ) = @_;
        $self->_sock_send( 'LLEN', $key );
}

=head2 lrange

  my @list = $r->lrange( $key, $start, $end );

=cut

sub lrange {
        my ( $self, $key, $start, $end ) = @_;
        my $size = $self->_sock_send('LRANGE', $key, $start, $end);

        confess $size unless $size > 0;
        $size--;

        my @list = ( 0 .. $size );
        foreach ( 0 .. $size ) {
                $list[ $_ ] = _sock_read_bulk();
        }

        warn "## lrange $key $start $end = [$size] ", dump( @list );
        return @list;
}

=head2 ltrim

  my $ok = $r->ltrim( $key, $start, $end );

=cut

sub ltrim {
        my ( $self, $key, $start, $end ) = @_;
        $self->_sock_send_ok( 'LTRIM', $key, $start, $end );
}

=head2 lindex

  $r->lindex( $key, $index );

=cut

sub lindex {
        my ( $self, $key, $index ) = @_;
        $self->_sock_result_bulk( 'LINDEX', $key, $index );
}

=head2 lset

  $r->lset( $key, $index, $value );

=cut

sub lset {
        my ( $self, $key, $index, $value ) = @_;
        $self->_sock_send_bulk( 'LSET', $key, $index, $value );
}

=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


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			Redis - The great new Redis!
13
14			=cut
15
16			our $VERSION = '0.01';
17
18
19			=head1 SYNOPSIS
20
21	dpavlin	2	Pure perl bindings for L<http://code.google.com/p/redis/>
22	dpavlin	1
23			use Redis;
24
25	dpavlin	2	my $r = Redis->new();
26	dpavlin	1
27
28
29	dpavlin	2
30	dpavlin	1	=head1 FUNCTIONS
31
32	dpavlin	2	=head2 new
33	dpavlin	1
34			=cut
35
36	dpavlin	2	our $sock;
37			my $server = '127.0.0.1:6379';
38
39			sub new {
40			my $class = shift;
41			my $self = {};
42			bless($self, $class);
43
44			warn "# opening socket to $server";
45
46			$sock \|\|= IO::Socket::INET->new(
47			PeerAddr => $server,
48			Proto => 'tcp',
49			) \|\| die $!;
50
51			$self;
52	dpavlin	1	}
53
54	dpavlin	11	sub _sock_result {
55			my $result = <$sock>;
56			warn "# result: ",dump( $result );
57			$result =~ s{\r\n$}{} \|\| warn "can't find cr/lf";
58			return $result;
59			}
60
61	dpavlin	21	sub _sock_read_bulk {
62	dpavlin	12	my $len = <$sock>;
63	dpavlin	21	warn "## bulk len: ",dump($len);
64	dpavlin	12	return undef if $len eq "nil\r\n";
65			my $v;
66			read($sock, $v, $len) \|\| die $!;
67	dpavlin	21	warn "## bulk v: ",dump($v);
68	dpavlin	12	my $crlf;
69			read($sock, $crlf, 2); # skip cr/lf
70			return $v;
71			}
72
73	dpavlin	21	sub _sock_result_bulk {
74			my $self = shift;
75			warn "## _sock_result_bulk ",dump( @_ );
76			print $sock join(' ',@_) . "\r\n";
77			_sock_read_bulk();
78			}
79
80	dpavlin	14	sub _sock_ok {
81			my $ok = <$sock>;
82			confess dump($ok) unless $ok eq "+OK\r\n";
83			}
84
85	dpavlin	20	sub _sock_send {
86			my $self = shift;
87	dpavlin	21	warn "## _sock_send ",dump( @_ );
88	dpavlin	20	print $sock join(' ',@_) . "\r\n";
89			_sock_result();
90			}
91
92	dpavlin	21	sub _sock_send_ok {
93			my $self = shift;
94			warn "## _sock_send_ok ",dump( @_ );
95			print $sock join(' ',@_) . "\r\n";
96			_sock_ok();
97			}
98
99	dpavlin	18	sub _sock_send_bulk {
100	dpavlin	24	my $self = shift;
101			my $value = pop;
102			print $sock join(' ',@_) . ' ' . length($value) . "\r\n$value\r\n";
103	dpavlin	18	_sock_ok();
104			}
105
106
107	dpavlin	2	=head1 Connection Handling
108	dpavlin	1
109	dpavlin	2	=head2 quit
110
111			$r->quit;
112
113	dpavlin	1	=cut
114
115	dpavlin	2	sub quit {
116			my $self = shift;
117
118			close( $sock ) \|\| warn $!;
119	dpavlin	1	}
120
121	dpavlin	2	=head2 ping
122
123	dpavlin	3	$r->ping \|\| die "no server?";
124	dpavlin	2
125			=cut
126
127			sub ping {
128			print $sock "PING\r\n";
129			my $pong = <$sock>;
130			die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
131			}
132
133	dpavlin	3	=head1 Commands operating on string values
134
135			=head2 set
136
137	dpavlin	5	$r->set( foo => 'bar', $new );
138	dpavlin	3
139			=cut
140
141			sub set {
142	dpavlin	18	my ( $self, $key, $value, $new ) = @_;
143			$self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
144	dpavlin	3	}
145
146			=head2 get
147
148			my $value = $r->get( 'foo' );
149
150			=cut
151
152			sub get {
153	dpavlin	21	my $self = shift;
154			$self->_sock_result_bulk('GET', @_);
155	dpavlin	3	}
156
157	dpavlin	7	=head2 incr
158	dpavlin	4
159	dpavlin	7	$r->incr('counter');
160			$r->incr('tripplets', 3);
161	dpavlin	4
162	dpavlin	7	=cut
163
164	dpavlin	10
165
166	dpavlin	7	sub incr {
167	dpavlin	21	my $self = shift;
168			$self->_sock_send( 'INCR' . ( $#_ ? 'BY' : '' ), @_ );
169	dpavlin	7	}
170
171	dpavlin	8	=head2 decr
172
173			$r->decr('counter');
174			$r->decr('tripplets', 3);
175
176			=cut
177
178			sub decr {
179	dpavlin	21	my $self = shift;
180			$self->_sock_send( 'DECR' . ( $#_ ? 'BY' : '' ), @_ );
181	dpavlin	8	}
182
183	dpavlin	9	=head2 exists
184
185			$r->exists( 'key' ) && print "got key!";
186
187			=cut
188
189			sub exists {
190			my ( $self, $key ) = @_;
191	dpavlin	21	$self->_sock_send( 'EXISTS', $key );
192	dpavlin	9	}
193
194	dpavlin	10	=head2 del
195
196			$r->del( 'key' ) \|\| warn "key doesn't exist";
197
198			=cut
199
200			sub del {
201			my ( $self, $key ) = @_;
202	dpavlin	21	$self->_sock_send( 'DEL', $key );
203	dpavlin	10	}
204
205	dpavlin	11	=head2 type
206
207			$r->type( 'key' ); # = string
208
209			=cut
210
211			sub type {
212			my ( $self, $key ) = @_;
213	dpavlin	21	$self->_sock_send( 'TYPE', $key );
214	dpavlin	11	}
215
216	dpavlin	12	=head1 Commands operating on the key space
217
218			=head2 keys
219
220			my @keys = $r->keys( 'glob_pattern' );
221
222			=cut
223
224			sub keys {
225			my ( $self, $glob ) = @_;
226	dpavlin	21	return split(/\s/, $self->_sock_result_bulk( 'KEYS', $glob ));
227	dpavlin	12	}
228
229	dpavlin	13	=head2 randomkey
230
231			my $key = $r->randomkey;
232
233			=cut
234
235			sub randomkey {
236	dpavlin	14	my ( $self ) = @_;
237	dpavlin	21	$self->_sock_send( 'RANDOMKEY' );
238	dpavlin	13	}
239
240	dpavlin	14	=head2 rename
241
242	dpavlin	15	my $ok = $r->rename( 'old-key', 'new-key', $new );
243	dpavlin	14
244			=cut
245
246			sub rename {
247			my ( $self, $old, $new, $nx ) = @_;
248	dpavlin	21	$self->_sock_send_ok( 'RENAME' . ( $nx ? 'NX' : '' ), $old, $new );
249	dpavlin	14	}
250
251	dpavlin	17	=head2 dbsize
252
253			my $nr_keys = $r->dbsize;
254
255			=cut
256
257			sub dbsize {
258			my ( $self ) = @_;
259	dpavlin	21	$self->_sock_send('DBSIZE');
260	dpavlin	17	}
261
262	dpavlin	18	=head1 Commands operating on lists
263
264			=head2 rpush
265
266			$r->rpush( $key, $value );
267
268			=cut
269
270			sub rpush {
271			my ( $self, $key, $value ) = @_;
272			$self->_sock_send_bulk('RPUSH', $key, $value);
273			}
274
275	dpavlin	19	=head2 lpush
276
277			$r->lpush( $key, $value );
278
279			=cut
280
281			sub lpush {
282			my ( $self, $key, $value ) = @_;
283			$self->_sock_send_bulk('LPUSH', $key, $value);
284			}
285
286	dpavlin	20	=head2 llen
287
288			$r->llen( $key );
289
290			=cut
291
292			sub llen {
293			my ( $self, $key ) = @_;
294	dpavlin	21	$self->_sock_send( 'LLEN', $key );
295	dpavlin	20	}
296
297	dpavlin	21	=head2 lrange
298
299			my @list = $r->lrange( $key, $start, $end );
300
301			=cut
302
303			sub lrange {
304			my ( $self, $key, $start, $end ) = @_;
305			my $size = $self->_sock_send('LRANGE', $key, $start, $end);
306
307			confess $size unless $size > 0;
308			$size--;
309
310			my @list = ( 0 .. $size );
311			foreach ( 0 .. $size ) {
312			$list[ $_ ] = _sock_read_bulk();
313			}
314
315			warn "## lrange $key $start $end = [$size] ", dump( @list );
316			return @list;
317			}
318
319	dpavlin	22	=head2 ltrim
320
321			my $ok = $r->ltrim( $key, $start, $end );
322
323			=cut
324
325			sub ltrim {
326			my ( $self, $key, $start, $end ) = @_;
327			$self->_sock_send_ok( 'LTRIM', $key, $start, $end );
328			}
329
330	dpavlin	23	=head2 lindex
331
332			$r->lindex( $key, $index );
333
334			=cut
335
336			sub lindex {
337			my ( $self, $key, $index ) = @_;
338	dpavlin	24	$self->_sock_result_bulk( 'LINDEX', $key, $index );
339	dpavlin	23	}
340
341	dpavlin	24	=head2 lset
342	dpavlin	23
343	dpavlin	24	$r->lset( $key, $index, $value );
344
345			=cut
346
347			sub lset {
348			my ( $self, $key, $index, $value ) = @_;
349			$self->_sock_send_bulk( 'LSET', $key, $index, $value );
350			}
351
352	dpavlin	1	=head1 AUTHOR
353
354			Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
355
356			=head1 BUGS
357
358			Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
359			the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
360			automatically be notified of progress on your bug as I make changes.
361
362
363
364
365			=head1 SUPPORT
366
367			You can find documentation for this module with the perldoc command.
368
369			perldoc Redis
370
371
372			You can also look for information at:
373
374			=over 4
375
376			=item * RT: CPAN's request tracker
377
378			L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
379
380			=item * AnnoCPAN: Annotated CPAN documentation
381
382			L<http://annocpan.org/dist/Redis>
383
384			=item * CPAN Ratings
385
386			L<http://cpanratings.perl.org/d/Redis>
387
388			=item * Search CPAN
389
390			L<http://search.cpan.org/dist/Redis>
391
392			=back
393
394
395			=head1 ACKNOWLEDGEMENTS
396
397
398			=head1 COPYRIGHT & LICENSE
399
400			Copyright 2009 Dobrica Pavlinusic, all rights reserved.
401
402			This program is free software; you can redistribute it and/or modify it
403			under the same terms as Perl itself.
404
405
406			=cut
407
408			1; # End of Redis