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

  ViewVC Help
Powered by ViewVC 1.1.26