X-Git-Url: https://git.saurik.com/redis.git/blobdiff_plain/5762b7f0f8d33eda021da908b6ddced684a2ba05..1259672feb4fcad189d413a341745990a844feda:/client-libraries/perl/lib/Redis.pm?ds=inline diff --git a/client-libraries/perl/lib/Redis.pm b/client-libraries/perl/lib/Redis.pm deleted file mode 100644 index 6a6d2789..00000000 --- a/client-libraries/perl/lib/Redis.pm +++ /dev/null @@ -1,422 +0,0 @@ -package Redis; - -use warnings; -use strict; - -use IO::Socket::INET; -use Data::Dump qw/dump/; -use Carp qw/confess/; - -=head1 NAME - -Redis - perl binding for Redis database - -=cut - -our $VERSION = '0.08'; - - -=head1 DESCRIPTION - -Pure perl bindings for L - -This version support git version 0.08 of Redis available at - -L - -This documentation -lists commands which are exercised in test suite, but -additinal commands will work correctly since protocol -specifies enough information to support almost all commands -with same peace of code with a little help of C. - -=head1 FUNCTIONS - -=head2 new - - my $r = Redis->new; - -=cut - -our $debug = $ENV{REDIS} || 0; - -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; -} - -my $bulk_command = { - set => 1, setnx => 1, - rpush => 1, lpush => 1, - lset => 1, lrem => 1, - sadd => 1, srem => 1, - sismember => 1, - echo => 1, -}; - -# we don't want DESTROY to fallback into AUTOLOAD -sub DESTROY {} - -our $AUTOLOAD; -sub AUTOLOAD { - my $self = shift; - - my $command = $AUTOLOAD; - $command =~ s/.*://; - - warn "## $command ",dump(@_) if $debug; - - my $send; - - if ( defined $bulk_command->{$command} ) { - my $value = pop; - $value = '' if ! defined $value; - $send - = uc($command) - . ' ' - . join(' ', @_) - . ' ' - . length( $value ) - . "\r\n$value\r\n" - ; - } else { - $send - = uc($command) - . ' ' - . join(' ', @_) - . "\r\n" - ; - } - - warn ">> $send" if $debug; - print $sock $send; - - if ( $command eq 'quit' ) { - close( $sock ) || die "can't close socket: $!"; - return 1; - } - - my $result = <$sock> || die "can't read socket: $!"; - warn "<< $result" if $debug; - my $type = substr($result,0,1); - $result = substr($result,1,-2); - - if ( $command eq 'info' ) { - my $hash; - foreach my $l ( split(/\r\n/, __sock_read_bulk($result) ) ) { - my ($n,$v) = split(/:/, $l, 2); - $hash->{$n} = $v; - } - return $hash; - } elsif ( $command eq 'keys' ) { - my $keys = __sock_read_bulk($result); - return split(/\s/, $keys) if $keys; - return; - } - - if ( $type eq '-' ) { - confess $result; - } elsif ( $type eq '+' ) { - return $result; - } elsif ( $type eq '$' ) { - return __sock_read_bulk($result); - } elsif ( $type eq '*' ) { - return __sock_read_multi_bulk($result); - } elsif ( $type eq ':' ) { - return $result; # FIXME check if int? - } else { - confess "unknown type: $type", __sock_read_line(); - } -} - -sub __sock_read_bulk { - my $len = shift; - return undef if $len < 0; - - my $v; - if ( $len > 0 ) { - read($sock, $v, $len) || die $!; - warn "<< ",dump($v),$/ if $debug; - } - my $crlf; - read($sock, $crlf, 2); # skip cr/lf - return $v; -} - -sub __sock_read_multi_bulk { - my $size = shift; - return undef if $size < 0; - - $size--; - - my @list = ( 0 .. $size ); - foreach ( 0 .. $size ) { - $list[ $_ ] = __sock_read_bulk( substr(<$sock>,1,-2) ); - } - - warn "## list = ", dump( @list ) if $debug; - return @list; -} - -1; - -__END__ - -=head1 Connection Handling - -=head2 quit - - $r->quit; - -=head2 ping - - $r->ping || die "no server?"; - -=head1 Commands operating on string values - -=head2 set - - $r->set( foo => 'bar' ); - - $r->setnx( foo => 42 ); - -=head2 get - - my $value = $r->get( 'foo' ); - -=head2 mget - - my @values = $r->mget( 'foo', 'bar', 'baz' ); - -=head2 incr - - $r->incr('counter'); - - $r->incrby('tripplets', 3); - -=head2 decr - - $r->decr('counter'); - - $r->decrby('tripplets', 3); - -=head2 exists - - $r->exists( 'key' ) && print "got key!"; - -=head2 del - - $r->del( 'key' ) || warn "key doesn't exist"; - -=head2 type - - $r->type( 'key' ); # = string - -=head1 Commands operating on the key space - -=head2 keys - - my @keys = $r->keys( '*glob_pattern*' ); - -=head2 randomkey - - my $key = $r->randomkey; - -=head2 rename - - my $ok = $r->rename( 'old-key', 'new-key', $new ); - -=head2 dbsize - - my $nr_keys = $r->dbsize; - -=head1 Commands operating on lists - -See also L for tie interface. - -=head2 rpush - - $r->rpush( $key, $value ); - -=head2 lpush - - $r->lpush( $key, $value ); - -=head2 llen - - $r->llen( $key ); - -=head2 lrange - - my @list = $r->lrange( $key, $start, $end ); - -=head2 ltrim - - my $ok = $r->ltrim( $key, $start, $end ); - -=head2 lindex - - $r->lindex( $key, $index ); - -=head2 lset - - $r->lset( $key, $index, $value ); - -=head2 lrem - - my $modified_count = $r->lrem( $key, $count, $value ); - -=head2 lpop - - my $value = $r->lpop( $key ); - -=head2 rpop - - my $value = $r->rpop( $key ); - -=head1 Commands operating on sets - -=head2 sadd - - $r->sadd( $key, $member ); - -=head2 srem - - $r->srem( $key, $member ); - -=head2 scard - - my $elements = $r->scard( $key ); - -=head2 sismember - - $r->sismember( $key, $member ); - -=head2 sinter - - $r->sinter( $key1, $key2, ... ); - -=head2 sinterstore - - my $ok = $r->sinterstore( $dstkey, $key1, $key2, ... ); - -=head1 Multiple databases handling commands - -=head2 select - - $r->select( $dbindex ); # 0 for new clients - -=head2 move - - $r->move( $key, $dbindex ); - -=head2 flushdb - - $r->flushdb; - -=head2 flushall - - $r->flushall; - -=head1 Sorting - -=head2 sort - - $r->sort("key BY pattern LIMIT start end GET pattern ASC|DESC ALPHA'); - -=head1 Persistence control commands - -=head2 save - - $r->save; - -=head2 bgsave - - $r->bgsave; - -=head2 lastsave - - $r->lastsave; - -=head2 shutdown - - $r->shutdown; - -=head1 Remote server control commands - -=head2 info - - my $info_hash = $r->info; - -=head1 AUTHOR - -Dobrica Pavlinusic, C<< >> - -=head1 BUGS - -Please report any bugs or feature requests to C, or through -the web interface at L. 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 - perldoc Redis::List - perldoc Redis::Hash - - -You can also look for information at: - -=over 4 - -=item * RT: CPAN's request tracker - -L - -=item * AnnoCPAN: Annotated CPAN documentation - -L - -=item * CPAN Ratings - -L - -=item * Search CPAN - -L - -=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