File Coverage

blib/lib/Prometheus/Tiny/Shared.pm

Criterion	Covered	Total	%
statement	97	97	100.0
branch	17	18	94.4
condition	46	54	85.1
subroutine	18	18	100.0
pod	8	8	100.0
total	186	195	95.3

package Prometheus::Tiny::Shared;
$Prometheus::Tiny::Shared::VERSION = '0.027';
# ABSTRACT: A tiny Prometheus client with a shared database behind it

use warnings;
use strict;

use Prometheus::Tiny 0.011;
use parent 'Prometheus::Tiny';

use Hash::SharedMem qw(shash_open shash_get shash_set shash_cset shash_keys_array shash_group_get_hash);
use JSON::XS qw(encode_json decode_json);
use File::Temp qw(tempdir);
use File::Path qw(rmtree);
use Carp qw(croak carp);
use Scalar::Util qw(looks_like_number);

sub new {
  my ($class, %args) = @_;

  if (exists $args{cache_args}) {
    croak <
The 'cache_args' argument to Prometheus::Tiny::Shared::new has been removed.
Read the docs for more info, and switch to the 'filename' argument.
EOF
  }

  my $filename = delete $args{filename};
  my $init_file = delete $args{init_file} || 0;

  my $self = $class->SUPER::new(%args);

  if ($filename) {
    rmtree($filename) if $init_file;
  }
  else {
    $filename = tempdir('pts-XXXXXXXX', TMPDIR => 1, CLEANUP => 1);
  }

  $self->{_shash} = shash_open($filename, 'rwc');

  return $self;
}

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 $key = join('-', 'k', $name, $self->_format_labels($labels));
  shash_set($self->{_shash}, $key, encode_json([$value, $timestamp]));

  return;
}

sub add {
  my ($self, $name, $diff, $labels) = @_;

  unless (looks_like_number $diff) {
    carp "adjusting '$name' by non-numeric value, adding 0 instead";
    $diff = 0;
  }

  my $key = join('-', 'k', $name, $self->_format_labels($labels));

  my ($ov, $nv);

  do {
    $ov = shash_get($self->{_shash}, $key);
    if ($ov) {
      my $ar = decode_json($ov);
      $ar->[0] += $diff;
      $nv = encode_json($ar);
    }
    else {
      $nv = encode_json([$diff]);
    }
  } until shash_cset($self->{_shash}, $key, $ov, $nv);

  return;
}

sub clear {
  my ($self, $name) = @_;

  for my $key (grep { substr($_, 0, 1) eq 'k' } @{shash_keys_array($self->{_shash})}) {
    shash_set($self->{_shash}, $key, undef);
  }

  return;
}

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

  my $key = join('-', 'm', $name);
  my $value = encode_json(\%meta);

  return if shash_cset($self->{_shash}, $key, undef, $value);

  my $old = decode_json(shash_get($self->{_shash}, $key));

  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";
  }

  return;
}

sub histogram_observe {
  my $self = shift;
  my ($name) = @_;

  my $key = join('-', 'm', $name);

  $self->{meta}{$name} = decode_json(shash_get($self->{_shash}, $key) || '{}');

  return $self->SUPER::histogram_observe(@_);
}

sub enum_set {
  my $self = shift;
  my ($name) = @_;

  my $key = join('-', 'm', $name);

  $self->{meta}{$name} = decode_json(shash_get($self->{_shash}, $key) || '{}');

  return $self->SUPER::enum_set(@_);
}

sub format {
  my $self = shift;

  my (%metrics, %meta);

  my $hash = shash_group_get_hash($self->{_shash});
  while ( my ($k, $v) = each %$hash ) {
    my ($t, $name, $fmt) = split '-', $k, 3;
    if ($t eq 'k') {
      $metrics{$name}{$fmt} = decode_json($v);
    }
    else {
      $meta{$name} = decode_json($v);
    }
  }
  $self->{metrics} = \%metrics;
  $self->{meta} = \%meta;

  return $self->SUPER::format(@_);
}

1;

__END__