view release on metacpan or  search on metacpan

lib/Bloomd/Client.pm  view on Meta::CPAN

#
# This file is part of Bloomd-Client
#
# This software is copyright (c) 2013 by Damien "dams" Krotkine.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Bloomd::Client;
{
  $Bloomd::Client::VERSION = '0.27';
}

# ABSTRACT: Perl client to the bloomd server

use feature ':5.10';
use Moo;
use List::MoreUtils qw(any mesh);
use Carp;
use Socket qw(:crlf);
use IO::Socket::INET;
use Errno qw(:POSIX);
use POSIX qw(strerror);
use Config;
use Types::Standard -types;


has protocol => ( is => 'ro', default => sub {'tcp'} );


has host => ( is => 'ro', isa => StrMatch[qr/.+/], default => sub {'127.0.0.1'} );


has port => ( is => 'ro', isa => Int, default => sub {8673} );
has _socket => ( is => 'lazy', predicate => 1, clearer => 1 );


has timeout => ( is => 'ro', , default => sub { 10 } );

has '_pid' => (is => 'ro', lazy => 1, clearer => 1, default => sub { $$ });


sub _build__socket {
    my ($self) = @_;
    my $socket = IO::Socket::INET->new(
        Proto => $self->protocol,
        PeerHost => $self->host,
        PeerPort => $self->port,
        Timeout  => $self->timeout,
    ) or die "Can't connect to server: $!";

    $self->timeout
      or return $socket;

    $Config{osname} eq 'netbsd' || $Config{osname} eq 'solaris'
      and croak "the timeout option is not yet supported on NetBSD or Solaris";

    my $seconds  = int( $self->timeout );
    my $useconds = int( 1_000_000 * ( $self->timeout - $seconds ) );
    my $timeout  = pack( 'l!l!', $seconds, $useconds );

    $socket->setsockopt( SOL_SOCKET, SO_RCVTIMEO, $timeout )
      or croak "setsockopt(SO_RCVTIMEO): $!";

    $socket->setsockopt( SOL_SOCKET, SO_SNDTIMEO, $timeout )
      or croak "setsockopt(SO_SNDTIMEO): $!";

    return $socket;

}


sub disconnect {
    my ($self) = @_;
    $self->_has_socket
      and $self->_socket->close;
    $self->_clear_socket;
}


sub create {
    my ($self, $name, $capacity, $prob, $in_memory) = @_;
    my $args =
        ( $capacity ? "capacity=$capacity" : '' )
      . ( $prob ? " prob=$prob" : '' )
      . ( $in_memory ? " in_memory=$in_memory" : '' );
    $self->_execute("create $name $args" ) eq 'Done';
}


sub list {
    my ($self, $prefix) = @_;
    $prefix //= '';
    my @keys = qw(name prob size capacity items);
    [
     map {
         my @values = split / /;
         +{ mesh @keys, @values };
     }
     $self->_execute("list $prefix" )
    ];
}


sub drop {
    my ($self, $name) = @_;
    $self->_execute("drop $name") eq 'Done';
}