File Coverage

blib/lib/Net/Statsd/Lite.pm

Criterion	Covered	Total	%
statement	111	111	100.0
branch	14	16	87.5
condition			n/a
subroutine	21	21	100.0
pod	4	6	66.6
total	150	154	97.4

package Net::Statsd::Lite;

# ABSTRACT: A lightweight StatsD client that supports multimetric packets

use v5.20;

use Moo 1.000000;

use Devel::StrictMode;
use IO::Socket 1.18 ();
use MooX::TypeTiny;
use Ref::Util qw/ is_plain_hashref /;
use Scalar::Util qw/ refaddr /;
use Sub::Quote qw/ quote_sub /;
use Sub::Util 1.40 qw/ set_subname /;
use Types::Common 2.000000 qw/ Bool Enum InstanceOf Int IntRange NonEmptySimpleStr
  NumRange PositiveInt PositiveOrZeroInt PositiveOrZeroNum SimpleStr StrMatch
  /;

use namespace::autoclean;

use experimental qw/ signatures /;

# RECOMMEND PREREQ: Ref::Util::XS
# RECOMMEND PREREQ: Type::Tiny::XS

our $VERSION = 'v0.8.0';


has host => (
    is      => 'ro',
    isa     => NonEmptySimpleStr,
    default => '127.0.0.1',
);


has port => (
    is      => 'ro',
    isa     => IntRange[ 0, 65535 ],
    default => 8125,
);


has proto => (
    is      => 'ro',
    isa     => Enum [qw/ tcp udp /],
    default => 'udp',
);


has prefix => (
    is      => 'ro',
    isa     => SimpleStr,
    default => '',
);


has autoflush => (
    is      => 'ro',
    isa     => Bool,
    default => 1,
);

my %Buffers;


has max_buffer_size => (
    is      => 'ro',
    isa     => PositiveInt,
    default => 512,
);

has _socket => (
    is      => 'lazy',
    isa     => InstanceOf ['IO::Socket::INET'],
    builder => sub($self) {
        my $sock = IO::Socket::INET->new(
            PeerAddr => $self->host,
            PeerPort => $self->port,
            Proto    => $self->proto,
        ) or die "Failed to initialize socket: $!";
        return $sock;
    },
    handles => { _send => 'send' },
);


BEGIN {
    my $class = __PACKAGE__;

    my %PROTOCOL = (
        set_add   => [ '|s',  SimpleStr, ],
        counter   => [ '|c',  Int, 1 ],
        gauge     => [ '|g',  StrMatch[ qr{\A[\-\+]?[0-9]+\z} ] ],
        histogram => [ '|h',  PositiveOrZeroNum, 1 ],
        meter     => [ '|m',  PositiveOrZeroNum ],
        timing    => [ '|ms', PositiveOrZeroNum, 1 ],
    );

    foreach my $name ( keys %PROTOCOL ) {

        my $type = $PROTOCOL{$name}[1];
        my $rate = $PROTOCOL{$name}[2];

        my $code = q{ my ($self, $metric, $value, $opts) = @_; };

        if (defined $rate) {
            $code .= q[ $opts = { rate => $opts } unless is_plain_hashref($opts); ] .
                     q[ my $rate = $opts->{rate} // 1; ]
        }
        else {
            $code .= q[ $opts //= {}; ];
        }

        if (STRICT) {

            $code .= $type->inline_assert('$value');

            if (defined $rate) {
                my $range = NumRange[0,1];
                $code .= $range->inline_assert('$rate') . ';';
            }
        }

        my $tmpl = $PROTOCOL{$name}[0];

        if ( defined $rate ) {

            $code .= q/ if ($rate<1) {
                     $self->record_metric( $tmpl . '|@' . $rate, $metric, $value, $opts )
                        if rand() <= $rate;
                   } else {
                     $self->record_metric( $tmpl, $metric, $value, $opts ); } /;
        }
        else {

            $code .= q{$self->record_metric( $tmpl, $metric, $value, $opts );};

        }

        quote_sub "${class}::${name}", $code,
          { '$tmpl'  => \$tmpl },
          { no_defer => 1 };

    }

    # Alises for other Net::Statsd::Client or Etsy::StatsD

    {
        no strict 'refs';    ## no critic (ProhibitNoStrict)

        *{"${class}::update"}    = set_subname "update"    => \&counter;
        *{"${class}::timing_ms"} = set_subname "timing_ms" => \&timing;

    }

}

sub increment( $self, $metric, $opts = undef ) {
    $self->counter( $metric, 1, $opts );
}

sub decrement( $self, $metric, $opts = undef ) {
    $self->counter( $metric, -1, $opts );
}


sub record_metric( $self, $suffix, $metric, $value, $ ) {

    my $data = $self->prefix . $metric . ':' . $value . $suffix . "\n";

    if ( $self->autoflush ) {
        send( $self->_socket, $data, 0 );
        return;
    }

    my $index = refaddr $self;
    my $avail = $self->max_buffer_size - length( $Buffers{$index} );

    $self->flush if length($data) > $avail;

    $Buffers{$index} .= $data;

}


sub flush($self) {
    my $index = refaddr $self;
    if ( $Buffers{$index} ne '' ) {
        send( $self->_socket, $Buffers{$index}, 0 );
        $Buffers{$index} = '';
    }
}

sub BUILD($self, $) {
    $Buffers{ refaddr $self } = '';
}

sub DEMOLISH( $self, $is_global ) {

    return if $is_global;

    $self->flush;

    delete $Buffers{ refaddr $self };
}


1;

__END__