view release on metacpan or  search on metacpan

lib/App/Memcached/CLI/DataSource.pm  view on Meta::CPAN

package App::Memcached::CLI::DataSource;

use strict;
use warnings;
use 5.008_001;

use Carp;
use IO::Socket;
use Time::HiRes;

use App::Memcached::CLI::Util qw(is_unixsocket debug);

sub new {
    my $class = shift;
    my %args  = @_;
    bless \%args, $class;
}

sub connect {
    my $class = shift;
    my $addr  = shift;
    my %opts  = @_;

    my $socket = sub {
        return IO::Socket::UNIX->new(Peer => $addr) if is_unixsocket($addr);
        return IO::Socket::INET->new(
            PeerAddr => $addr,
            Proto    => 'tcp',
            Timeout  => $opts{timeout} || 1,
        );
    }->();
    confess "Can't connect to $addr" unless $socket;

    return $class->new(socket => $socket);
}

sub ping {
    my $self = shift;
    my $version = eval {
        return $self->query_one('version');
    };
    if (!$version or $@) {
        debug "Ping failed.";
        debug "ERROR: " . $@ if $@;
        return;
    }
    return 1;
}

sub get {
    my $self = shift;
    return $self->_retrieve('get', shift);
}

sub gets {
    my $self = shift;
    return $self->_retrieve('gets', shift);
}

sub _retrieve {
    my $self = shift;
    my ($cmd, $keys) = @_;

    my $key_str = join(q{ }, @$keys);
    $self->{socket}->write("$cmd $key_str\r\n");

    my @results;

    while (1) {
        my $response = $self->_readline;
        next if ($response =~ m/^[\r\n]+$/);
        if ($response =~ m/^VALUE (\S+) (\d+) (\d+)(?: (\d+))?/) {
            my %data = (
                key    => $1,
                flags  => $2,
                length => $3,
                cas    => $4,
            );
            local $SIG{ALRM} = sub { die 'Timed out to Read Socket.' };
            alarm 3;
            $self->{socket}->read($response, $data{length});
            alarm 0;
            $data{value} = $response;
            push @results, \%data;
        } elsif ($response =~ m/^END/) {
            last;
        } else {
            warn "Unknown response '$response'";
        }