File Coverage

blib/lib/Prometheus/Tiny.pm

Criterion	Covered	Total	%
statement	99	99	100.0
branch	40	46	86.9
condition	43	51	84.3
subroutine	17	17	100.0
pod	11	11	100.0
total	210	224	93.7

package Prometheus::Tiny;
$Prometheus::Tiny::VERSION = '0.011';
# ABSTRACT: A tiny Prometheus client

use warnings;
use strict;

use Carp qw(croak carp);
use Scalar::Util qw(looks_like_number);

my $DEFAULT_BUCKETS = [
               0.005,
  0.01, 0.025, 0.05, 0.075,
  0.1,  0.25,  0.5,  0.75,
  1.0,  2.5,   5.0,  7.5,
  10
];

sub new {
  my ($class, %arg) = @_;
  my %defaults = $arg{default_labels} ? %{$arg{default_labels}} : ();
  return bless {
    metrics => {},
    meta => {},
    default_labels => \%defaults,
  }, $class;
}

sub _format_labels {
  my ($self, $labels) = @_;

  # Avoid copying the labels hash unless we need to add defaults.
  my $to_format = $self->{default_labels}
                ? { %{$self->{default_labels}}, %{$labels || {}} }
                : $labels;

  join ',', map {
    my $lv = $to_format->{$_};
    if (defined $lv) {
      $lv =~ s/(["\\])/\\$1/sg;
      $lv =~ s/\n/\\n/sg;
      qq{$_="$lv"}
    } else {
      carp "label '$_' has an undefined value, dropping it";
      ()
    }
  } sort keys %$to_format;
}

sub set {
  my ($self, $name, $value, $labels, $timestamp) = @_;
  unless (looks_like_number $value) {
    carp "setting '$name' to non-numeric value, using 0 instead";
    $value = 0;
  }
  my $f_label = $self->_format_labels($labels);
  $self->{metrics}{$name}{$f_label} = [ $value, $timestamp ];
  return;
}

sub add {
  my ($self, $name, $value, $labels) = @_;
  unless (looks_like_number $value) {
    carp "adjusting '$name' by non-numeric value, adding 0 instead";
    $value = 0;
  }
  $self->{metrics}{$name}{$self->_format_labels($labels)}->[0] += $value;
  return;
}

sub inc {
  my ($self, $name, $labels) = @_;
  return $self->add($name, 1, $labels);
}

sub dec {
  my ($self, $name, $labels) = @_;
  return $self->add($name, -1, $labels);
}

sub clear {
  my ($self, $name) = @_;
  $self->{metrics} = {};
  return;
}

sub histogram_observe {
  my ($self, $name, $value, $labels) = @_;

  $self->inc($name.'_count', $labels);
  $self->add($name.'_sum', $value, $labels);

  my @buckets = @{$self->{meta}{$name}{buckets} || $DEFAULT_BUCKETS};

  my $bucket_metric = $name.'_bucket';
  for my $bucket (@buckets) {
    $self->add($bucket_metric, $value <= $bucket ? 1 : 0, { %{$labels || {}} , le => $bucket });
  }
  $self->inc($bucket_metric, { %{$labels || {}}, le => '+Inf' });

  return;
}

sub enum_set {
  my ($self, $name, $value, $labels, $timestamp) = @_;

  my $enum_label = $self->{meta}{$name}{enum} ||
    croak "enum not declared for '$name'";

  for my $ev (@{$self->{meta}{$name}{enum_values} || []}) {
    $self->set($name, $value eq $ev ? 1 : 0, { %{$labels || {}}, $enum_label => $ev }, $timestamp);
  }
}

sub declare {
  my ($self, $name, %meta) = @_;

  if (my $old = $self->{meta}{$name}) {
    if (
      ((exists $old->{type} ^ exists $meta{type}) ||
       (exists $old->{type} && $old->{type} ne $meta{type})) ||
      ((exists $old->{help} ^ exists $meta{help}) ||
       (exists $old->{help} && $old->{help} ne $meta{help})) ||
      ((exists $old->{enum} ^ exists $meta{enum}) ||
       (exists $old->{enum} && $old->{enum} ne $meta{enum})) ||
      ((exists $old->{buckets} ^ exists $meta{buckets}) ||
       (exists $old->{buckets} && (
        @{$old->{buckets}} ne @{$meta{buckets}} ||
        grep { $old->{buckets}[$_] != $meta{buckets}[$_] } (0 .. $#{$meta{buckets}})
       ))
      ) ||
      ((exists $old->{enum_values} ^ exists $meta{enum_values}) ||
       (exists $old->{enum_values} && (
        @{$old->{enum_values}} ne @{$meta{enum_values}} ||
        grep { $old->{enum_values}[$_] ne $meta{enum_values}[$_] } (0 .. $#{$meta{enum_values}})
       ))
      )
    ) {
      croak "redeclaration of '$name' with mismatched meta";
    }
  }

  $self->{meta}{$name} = { %meta };
  return;
}

sub format {
  my ($self) = @_;
  my %names = map { $_ => 1 } (keys %{$self->{metrics}}, keys %{$self->{meta}});
  return join '', map {
    my $name = $_;
    (
      (defined $self->{meta}{$name}{help} ?
        ("# HELP $name $self->{meta}{$name}{help}\n") : ()),
      (defined $self->{meta}{$name}{type} ?
        ("# TYPE $name $self->{meta}{$name}{type}\n") : ()),
      (map {
        my $v = join ' ', grep { defined $_ } @{$self->{metrics}{$name}{$_}};
        $_ ?
          join '', $name, '{', $_, '} ', $v, "\n" :
          join '', $name, ' ', $v, "\n"
      } sort {
        $name =~ m/_bucket$/ ?
          do {
            my $t_a = $a; $t_a =~ s/le="([^"]+)"//; my $le_a = $1;
            my $t_b = $b; $t_b =~ s/le="([^"]+)"//; my $le_b = $1;
            $t_a eq $t_b ?
              do {
                $le_a eq '+Inf' ? 1 :
                $le_b eq '+Inf' ? -1 :
                ($a cmp $b)
              } :
              ($a cmp $b)
          } :
          ($a cmp $b)
      } keys %{$self->{metrics}{$name}}),
    )
  } sort keys %names;
}

sub psgi {
  my ($self) = @_;
  return sub {
    my ($env) = @_;
    return [ 405, [], [] ] unless $env->{REQUEST_METHOD} eq 'GET';
    return [ 200, [ 'Content-Type' => 'text/plain' ], [ $self->format ] ];
  };
}

1;

__END__