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

=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, $k, $v, $new ) = @_;
        print $sock ( $new ? "SETNX" : "SET" ) . " $k " . length($v) . "\r\n$v\r\n";
        my $ok = <$sock>;
        confess dump($ok) unless $ok eq "+OK\r\n";
}

=head2 get

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

=cut

sub get {
        my ( $self, $k ) = @_;
        print $sock "GET $k\r\n";
        _sock_result_bulk();
}

=head2 incr

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

=cut

        
sub incr {
        my ( $self, $key, $value ) = @_;
        if ( defined $value ) {
                print $sock "INCRBY $key $value\r\n";
        } else {
                print $sock "INCR $key\r\n";
        }
        _sock_result();
}

=head2 decr

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

=cut

sub decr {
        my ( $self, $key, $value ) = @_;
        if ( defined $value ) {
                print $sock "DECRBY $key $value\r\n";
        } else {
                print $sock "DECR $key\r\n";
        }
        _sock_result();
}

=head2 exists

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

=cut

sub exists {
        my ( $self, $key ) = @_;
        print $sock "EXISTS $key\r\n";
        _sock_result();
}

=head2 del

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

=cut

sub del {
        my ( $self, $key ) = @_;
        print $sock "DEL $key\r\n";
        _sock_result();
}

=head2 type

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

=cut

sub type {
        my ( $self, $key ) = @_;
        print $sock "TYPE $key\r\n";
        _sock_result();
}

=head1 Commands operating on the key space

=head2 keys

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

=cut

sub keys {
        my ( $self, $glob ) = @_;
        print $sock "KEYS $glob\r\n";
        return split(/\s/, _sock_result_bulk());
}

=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	12	sub _sock_result_bulk {
62			my $len = <$sock>;
63			warn "# len: ",dump($len);
64			return undef if $len eq "nil\r\n";
65			my $v;
66			read($sock, $v, $len) \|\| die $!;
67			warn "# v: ",dump($v);
68			my $crlf;
69			read($sock, $crlf, 2); # skip cr/lf
70			return $v;
71			}
72
73	dpavlin	2	=head1 Connection Handling
74	dpavlin	1
75	dpavlin	2	=head2 quit
76
77			$r->quit;
78
79	dpavlin	1	=cut
80
81	dpavlin	2	sub quit {
82			my $self = shift;
83
84			close( $sock ) \|\| warn $!;
85	dpavlin	1	}
86
87	dpavlin	2	=head2 ping
88
89	dpavlin	3	$r->ping \|\| die "no server?";
90	dpavlin	2
91			=cut
92
93			sub ping {
94			print $sock "PING\r\n";
95			my $pong = <$sock>;
96			die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
97			}
98
99	dpavlin	3	=head1 Commands operating on string values
100
101			=head2 set
102
103	dpavlin	5	$r->set( foo => 'bar', $new );
104	dpavlin	3
105			=cut
106
107			sub set {
108	dpavlin	5	my ( $self, $k, $v, $new ) = @_;
109			print $sock ( $new ? "SETNX" : "SET" ) . " $k " . length($v) . "\r\n$v\r\n";
110	dpavlin	3	my $ok = <$sock>;
111	dpavlin	5	confess dump($ok) unless $ok eq "+OK\r\n";
112	dpavlin	3	}
113
114			=head2 get
115
116			my $value = $r->get( 'foo' );
117
118			=cut
119
120			sub get {
121			my ( $self, $k ) = @_;
122			print $sock "GET $k\r\n";
123	dpavlin	12	_sock_result_bulk();
124	dpavlin	3	}
125
126	dpavlin	7	=head2 incr
127	dpavlin	4
128	dpavlin	7	$r->incr('counter');
129			$r->incr('tripplets', 3);
130	dpavlin	4
131	dpavlin	7	=cut
132
133	dpavlin	10
134
135	dpavlin	7	sub incr {
136			my ( $self, $key, $value ) = @_;
137			if ( defined $value ) {
138			print $sock "INCRBY $key $value\r\n";
139			} else {
140			print $sock "INCR $key\r\n";
141			}
142	dpavlin	11	_sock_result();
143	dpavlin	7	}
144
145	dpavlin	8	=head2 decr
146
147			$r->decr('counter');
148			$r->decr('tripplets', 3);
149
150			=cut
151
152			sub decr {
153			my ( $self, $key, $value ) = @_;
154			if ( defined $value ) {
155			print $sock "DECRBY $key $value\r\n";
156			} else {
157			print $sock "DECR $key\r\n";
158			}
159	dpavlin	11	_sock_result();
160	dpavlin	8	}
161
162	dpavlin	9	=head2 exists
163
164			$r->exists( 'key' ) && print "got key!";
165
166			=cut
167
168			sub exists {
169			my ( $self, $key ) = @_;
170			print $sock "EXISTS $key\r\n";
171	dpavlin	11	_sock_result();
172	dpavlin	9	}
173
174	dpavlin	10	=head2 del
175
176			$r->del( 'key' ) \|\| warn "key doesn't exist";
177
178			=cut
179
180			sub del {
181			my ( $self, $key ) = @_;
182			print $sock "DEL $key\r\n";
183	dpavlin	11	_sock_result();
184	dpavlin	10	}
185
186	dpavlin	11	=head2 type
187
188			$r->type( 'key' ); # = string
189
190			=cut
191
192			sub type {
193			my ( $self, $key ) = @_;
194	dpavlin	12	print $sock "TYPE $key\r\n";
195	dpavlin	11	_sock_result();
196			}
197
198	dpavlin	12	=head1 Commands operating on the key space
199
200			=head2 keys
201
202			my @keys = $r->keys( 'glob_pattern' );
203
204			=cut
205
206			sub keys {
207			my ( $self, $glob ) = @_;
208			print $sock "KEYS $glob\r\n";
209			return split(/\s/, _sock_result_bulk());
210			}
211
212	dpavlin	1	=head1 AUTHOR
213
214			Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
215
216			=head1 BUGS
217
218			Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
219			the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
220			automatically be notified of progress on your bug as I make changes.
221
222
223
224
225			=head1 SUPPORT
226
227			You can find documentation for this module with the perldoc command.
228
229			perldoc Redis
230
231
232			You can also look for information at:
233
234			=over 4
235
236			=item * RT: CPAN's request tracker
237
238			L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
239
240			=item * AnnoCPAN: Annotated CPAN documentation
241
242			L<http://annocpan.org/dist/Redis>
243
244			=item * CPAN Ratings
245
246			L<http://cpanratings.perl.org/d/Redis>
247
248			=item * Search CPAN
249
250			L<http://search.cpan.org/dist/Redis>
251
252			=back
253
254
255			=head1 ACKNOWLEDGEMENTS
256
257
258			=head1 COPYRIGHT & LICENSE
259
260			Copyright 2009 Dobrica Pavlinusic, all rights reserved.
261
262			This program is free software; you can redistribute it and/or modify it
263			under the same terms as Perl itself.
264
265
266			=cut
267
268			1; # End of Redis