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

  ViewVC Help
Powered by ViewVC 1.1.26