File Coverage

blib/lib/Monitoring/Plugin/Performance.pm
Criterion Covered Total %
statement 86 86 100.0
branch 22 22 100.0
condition 12 17 70.5
subroutine 18 18 100.0
pod 6 6 100.0
total 144 149 96.6


line stmt bran cond sub pod time code
1             package Monitoring::Plugin::Performance;
2              
3 4     4   4195 use 5.006;
  4         12  
  4         171  
4 4     4   19 use strict;
  4         6  
  4         143  
5 4     4   18 use warnings;
  4         5  
  4         130  
6              
7 4     4   19 use Carp;
  4         23  
  4         307  
8 4     4   22 use base qw(Class::Accessor::Fast);
  4         4  
  4         1468  
9             __PACKAGE__->mk_ro_accessors(
10             qw(label value uom warning critical min max)
11             );
12              
13 4     4   5590 use Monitoring::Plugin::Functions;
  4         11  
  4         308  
14 4     4   1194 use Monitoring::Plugin::Threshold;
  4         6  
  4         27  
15 4     4   124 use Monitoring::Plugin::Range;
  4         9  
  4         17  
16             our ($VERSION) = $Monitoring::Plugin::Functions::VERSION;
17              
18             sub import {
19 4     4   612 my ($class, %attr) = @_;
20 4   100     28 $_ = $attr{use_die} || 0;
21 4         18 Monitoring::Plugin::Functions::_use_die($_);
22             }
23              
24             # This is NOT the same as N::P::Functions::value_re. We leave that to be the strict
25             # version. This one allows commas to be part of the numeric value.
26             my $value = qr/[-+]?[\d\.,]+/;
27             my $value_re = qr/$value(?:e$value)?/;
28             my $value_with_negative_infinity = qr/$value_re|~/;
29             sub _parse {
30 41     41   40 my $class = shift;
31 41         37 my $string = shift;
32 41         447 $string =~ /^'?([^'=]+)'?=($value_re)([\w%]*);?($value_with_negative_infinity\:?$value_re?)?;?($value_with_negative_infinity\:?$value_re?)?;?($value_re)?;?($value_re)?/o;
33 41 100 66     332 return undef unless ((defined $1 && $1 ne "") && (defined $2 && $2 ne ""));
      66        
      66        
34 37         137 my @info = ($1, $2, $3, $4, $5, $6, $7);
35             # We convert any commas to periods, in the value fields
36 37 100       51 map { defined $info[$_] && $info[$_] =~ s/,/./go } (1, 3, 4, 5, 6);
  185         463  
37              
38             # Check that $info[1] is an actual value
39             # We do this by returning undef if a warning appears
40 37         33 my $performance_value;
41             {
42 37         28 my $not_value;
  37         24  
43 37     1   192 local $SIG{__WARN__} = sub { $not_value++ };
  1         5  
44 37         91 $performance_value = $info[1]+0;
45 37 100       149 return undef if $not_value;
46             }
47 36         92 my $p = $class->new(
48             label => $info[0], value => $performance_value, uom => $info[2], warning => $info[3], critical => $info[4],
49             min => $info[5], max => $info[6]
50             );
51 36         450 return $p;
52             }
53              
54             # Map undef to ''
55             sub _nvl {
56 185     185   587 my ($self, $value) = @_;
57 185 100       449 defined $value ? $value : ''
58             }
59              
60             sub perfoutput {
61 37     37 1 178 my $self = shift;
62             # Add quotes if label contains a space character
63 37         58 my $label = $self->label;
64 37 100       149 if ($label =~ / /) {
65 2         5 $label = "'$label'";
66             }
67 37         62 my $out = sprintf "%s=%s%s;%s;%s;%s;%s",
68             $label,
69             $self->value,
70             $self->_nvl($self->uom),
71             $self->_nvl($self->warning),
72             $self->_nvl($self->critical),
73             $self->_nvl($self->min),
74             $self->_nvl($self->max);
75             # Previous implementation omitted trailing ;; - do we need this?
76 37         117 $out =~ s/;;$//;
77 37         141 return $out;
78             }
79              
80             sub parse_perfstring {
81 29     29 1 12220 my ($class, $perfstring) = @_;
82 29         41 my @perfs = ();
83 29         26 my $obj;
84 29         57 while ($perfstring) {
85 41         164 $perfstring =~ s/^\s*//;
86             # If there is more than 1 equals sign, split it out and parse individually
87 41 100       37 if (@{[$perfstring =~ /=/g]} > 1) {
  41         164  
88 14         73 $perfstring =~ s/^(.*?=.*?)\s//;
89 14 100       36 if (defined $1) {
90 13         31 $obj = $class->_parse($1);
91             } else {
92             # This could occur if perfdata was soemthing=value=
93             # Since this is invalid, we reset the string and continue
94 1         3 $perfstring = "";
95 1         4 $obj = $class->_parse($perfstring);
96             }
97             } else {
98 27         52 $obj = $class->_parse($perfstring);
99 27         35 $perfstring = "";
100             }
101 41 100       135 push @perfs, $obj if $obj;
102             }
103 29         112 return @perfs;
104             }
105              
106             sub rrdlabel {
107 15     15 1 9365 my $self = shift;
108 15         29 my $name = $self->clean_label;
109             # Shorten
110 15         60 return substr( $name, 0, 19 );
111             }
112              
113             sub clean_label {
114 20     20 1 20 my $self = shift;
115 20         43 my $name = $self->label;
116 20 100       141 if ($name eq "/") {
    100          
117 3         3 $name = "root";
118             } elsif ( $name =~ s/^\/// ) {
119 6         12 $name =~ s/\//_/g;
120             }
121             # Convert all other characters
122 20         57 $name =~ s/\W/_/g;
123 20         41 return $name;
124             }
125              
126             # Backward compatibility: create a threshold object on the fly as requested
127             sub threshold
128             {
129 90     90 1 40003 my $self = shift;
130 90         205 return Monitoring::Plugin::Threshold->set_thresholds(
131             warning => $self->warning, critical => $self->critical
132             );
133             }
134              
135             # Constructor - unpack thresholds, map args to hashref
136             sub new
137             {
138 48     48 1 6625 my $class = shift;
139 48         230 my %arg = @_;
140              
141             # Convert thresholds
142 48 100       110 if (my $threshold = delete $arg{threshold}) {
143 7   66     26 $arg{warning} ||= $threshold->warning . "";
144 7   66     138 $arg{critical} ||= $threshold->critical . "";
145             }
146              
147 48         229 $class->SUPER::new(\%arg);
148             }
149              
150             1;
151              
152             __END__