/[Redis.pre-github]/lib/Redis.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /lib/Redis.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 19 - (hide annotations)
Sun Mar 22 09:46:14 2009 UTC (15 years ago) by dpavlin
File size: 4888 byte(s)
lpush
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 14 sub _sock_ok {
74     my $ok = <$sock>;
75     confess dump($ok) unless $ok eq "+OK\r\n";
76     }
77    
78 dpavlin 18 sub _sock_send_bulk {
79     my ( $self, $command, $key, $value ) = @_;
80     print $sock "$command $key " . length($value) . "\r\n$value\r\n";
81     _sock_ok();
82     }
83    
84    
85 dpavlin 2 =head1 Connection Handling
86 dpavlin 1
87 dpavlin 2 =head2 quit
88    
89     $r->quit;
90    
91 dpavlin 1 =cut
92    
93 dpavlin 2 sub quit {
94     my $self = shift;
95    
96     close( $sock ) || warn $!;
97 dpavlin 1 }
98    
99 dpavlin 2 =head2 ping
100    
101 dpavlin 3 $r->ping || die "no server?";
102 dpavlin 2
103     =cut
104    
105     sub ping {
106     print $sock "PING\r\n";
107     my $pong = <$sock>;
108     die "ping failed, got ", dump($pong) unless $pong eq "+PONG\r\n";
109     }
110    
111 dpavlin 3 =head1 Commands operating on string values
112    
113     =head2 set
114    
115 dpavlin 5 $r->set( foo => 'bar', $new );
116 dpavlin 3
117     =cut
118    
119     sub set {
120 dpavlin 18 my ( $self, $key, $value, $new ) = @_;
121     $self->_sock_send_bulk( "SET" . ( $new ? 'NX' : '' ), $key, $value );
122 dpavlin 3 }
123    
124     =head2 get
125    
126     my $value = $r->get( 'foo' );
127    
128     =cut
129    
130     sub get {
131     my ( $self, $k ) = @_;
132     print $sock "GET $k\r\n";
133 dpavlin 12 _sock_result_bulk();
134 dpavlin 3 }
135    
136 dpavlin 7 =head2 incr
137 dpavlin 4
138 dpavlin 7 $r->incr('counter');
139     $r->incr('tripplets', 3);
140 dpavlin 4
141 dpavlin 7 =cut
142    
143 dpavlin 10
144    
145 dpavlin 7 sub incr {
146     my ( $self, $key, $value ) = @_;
147     if ( defined $value ) {
148     print $sock "INCRBY $key $value\r\n";
149     } else {
150     print $sock "INCR $key\r\n";
151     }
152 dpavlin 11 _sock_result();
153 dpavlin 7 }
154    
155 dpavlin 8 =head2 decr
156    
157     $r->decr('counter');
158     $r->decr('tripplets', 3);
159    
160     =cut
161    
162     sub decr {
163     my ( $self, $key, $value ) = @_;
164     if ( defined $value ) {
165     print $sock "DECRBY $key $value\r\n";
166     } else {
167     print $sock "DECR $key\r\n";
168     }
169 dpavlin 11 _sock_result();
170 dpavlin 8 }
171    
172 dpavlin 9 =head2 exists
173    
174     $r->exists( 'key' ) && print "got key!";
175    
176     =cut
177    
178     sub exists {
179     my ( $self, $key ) = @_;
180     print $sock "EXISTS $key\r\n";
181 dpavlin 11 _sock_result();
182 dpavlin 9 }
183    
184 dpavlin 10 =head2 del
185    
186     $r->del( 'key' ) || warn "key doesn't exist";
187    
188     =cut
189    
190     sub del {
191     my ( $self, $key ) = @_;
192     print $sock "DEL $key\r\n";
193 dpavlin 11 _sock_result();
194 dpavlin 10 }
195    
196 dpavlin 11 =head2 type
197    
198     $r->type( 'key' ); # = string
199    
200     =cut
201    
202     sub type {
203     my ( $self, $key ) = @_;
204 dpavlin 12 print $sock "TYPE $key\r\n";
205 dpavlin 11 _sock_result();
206     }
207    
208 dpavlin 12 =head1 Commands operating on the key space
209    
210     =head2 keys
211    
212     my @keys = $r->keys( '*glob_pattern*' );
213    
214     =cut
215    
216     sub keys {
217     my ( $self, $glob ) = @_;
218     print $sock "KEYS $glob\r\n";
219     return split(/\s/, _sock_result_bulk());
220     }
221    
222 dpavlin 13 =head2 randomkey
223    
224     my $key = $r->randomkey;
225    
226     =cut
227    
228     sub randomkey {
229 dpavlin 14 my ( $self ) = @_;
230 dpavlin 13 print $sock "RANDOMKEY\r\n";
231     _sock_result();
232     }
233    
234 dpavlin 14 =head2 rename
235    
236 dpavlin 15 my $ok = $r->rename( 'old-key', 'new-key', $new );
237 dpavlin 14
238     =cut
239    
240     sub rename {
241     my ( $self, $old, $new, $nx ) = @_;
242     print $sock "RENAME" . ( $nx ? 'NX' : '' ) . " $old $new\r\n";
243     _sock_ok();
244     }
245    
246 dpavlin 17 =head2 dbsize
247    
248     my $nr_keys = $r->dbsize;
249    
250     =cut
251    
252     sub dbsize {
253     my ( $self ) = @_;
254     print $sock "DBSIZE\r\n";
255     _sock_result();
256     }
257    
258 dpavlin 18 =head1 Commands operating on lists
259    
260     =head2 rpush
261    
262     $r->rpush( $key, $value );
263    
264     =cut
265    
266     sub rpush {
267     my ( $self, $key, $value ) = @_;
268     $self->_sock_send_bulk('RPUSH', $key, $value);
269     }
270    
271 dpavlin 19 =head2 lpush
272    
273     $r->lpush( $key, $value );
274    
275     =cut
276    
277     sub lpush {
278     my ( $self, $key, $value ) = @_;
279     $self->_sock_send_bulk('LPUSH', $key, $value);
280     }
281    
282 dpavlin 1 =head1 AUTHOR
283    
284     Dobrica Pavlinusic, C<< <dpavlin at rot13.org> >>
285    
286     =head1 BUGS
287    
288     Please report any bugs or feature requests to C<bug-redis at rt.cpan.org>, or through
289     the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Redis>. I will be notified, and then you'll
290     automatically be notified of progress on your bug as I make changes.
291    
292    
293    
294    
295     =head1 SUPPORT
296    
297     You can find documentation for this module with the perldoc command.
298    
299     perldoc Redis
300    
301    
302     You can also look for information at:
303    
304     =over 4
305    
306     =item * RT: CPAN's request tracker
307    
308     L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Redis>
309    
310     =item * AnnoCPAN: Annotated CPAN documentation
311    
312     L<http://annocpan.org/dist/Redis>
313    
314     =item * CPAN Ratings
315    
316     L<http://cpanratings.perl.org/d/Redis>
317    
318     =item * Search CPAN
319    
320     L<http://search.cpan.org/dist/Redis>
321    
322     =back
323    
324    
325     =head1 ACKNOWLEDGEMENTS
326    
327    
328     =head1 COPYRIGHT & LICENSE
329    
330     Copyright 2009 Dobrica Pavlinusic, all rights reserved.
331    
332     This program is free software; you can redistribute it and/or modify it
333     under the same terms as Perl itself.
334    
335    
336     =cut
337    
338     1; # End of Redis

  ViewVC Help
Powered by ViewVC 1.1.26