File Coverage

blib/lib/Monitoring/Plugin/Performance.pm
Criterion Covered Total %
statement 87 88 98.8
branch 23 24 95.8
condition 12 17 70.5
subroutine 18 18 100.0
pod 6 6 100.0
total 146 153 95.4


line stmt bran cond sub pod time code
1             package Monitoring::Plugin::Performance;
2              
3 4     4   3151 use 5.006;
  4         14  
4 4     4   23 use strict;
  4         6  
  4         71  
5 4     4   12 use warnings;
  4         7  
  4         92  
6              
7 4     4   21 use Carp;
  4         7  
  4         175  
8 4     4   16 use base qw(Class::Accessor::Fast);
  4         5  
  4         863  
9             __PACKAGE__->mk_ro_accessors(
10             qw(label value uom warning critical min max)
11             );
12              
13 4     4   4106 use Monitoring::Plugin::Functions;
  4         6  
  4         224  
14 4     4   814 use Monitoring::Plugin::Threshold;
  4         7  
  4         26  
15 4     4   115 use Monitoring::Plugin::Range;
  4         6  
  4         11  
16             our ($VERSION) = $Monitoring::Plugin::Functions::VERSION;
17              
18             sub import {
19 4     4   650 my ($class, %attr) = @_;
20 4   100     18 $_ = $attr{use_die} || 0;
21 4         12 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   54 my $class = shift;
31 41         62 my $string = shift;
32 41         379 $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     225 return undef unless ((defined $1 && $1 ne "") && (defined $2 && $2 ne ""));
      66        
      66        
34 37         128 my @info = ($1, $2, $3, $4, $5, $6, $7);
35             # We convert any commas to periods, in the value fields
36 37 100       54 map { defined $info[$_] && $info[$_] =~ s/,/./go } (1, 3, 4, 5, 6);
  185         412  
37              
38             # Check that $info[1] is an actual value
39             # We do this by returning undef if a warning appears
40 37         41 my $performance_value;
41             {
42 37         36 my $not_value;
  37         34  
43 37     1   172 local $SIG{__WARN__} = sub { $not_value++ };
  1         5  
44 37         96 $performance_value = $info[1]+0;
45 37 100       128 return undef if $not_value;
46             }
47 36         86 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         306 return $p;
52             }
53              
54             # Map undef to ''
55             sub _nvl {
56 185     185   637 my ($self, $value) = @_;
57 185 100       1921 defined $value ? $value : ''
58             }
59              
60             sub perfoutput {
61 37     37 1 157 my $self = shift;
62             # Add quotes if label contains a space character
63 37         478 my $label = $self->label;
64 37 100       173 if ($label =~ / /) {
65 2         4 $label = "'$label'";
66             }
67            
68 37         437 my $value = $self->value;
69             # To prevent invalid output, we change empty value to value "U"
70 37 50       131 if ($value eq '') {
71 0         0 $value = 'U';
72             }
73            
74 37         434 my $out = sprintf "%s=%s%s;%s;%s;%s;%s",
75             $label,
76             $value,
77             $self->_nvl($self->uom),
78             $self->_nvl($self->warning),
79             $self->_nvl($self->critical),
80             $self->_nvl($self->min),
81             $self->_nvl($self->max);
82             # Previous implementation omitted trailing ;; - do we need this?
83 37         129 $out =~ s/;;$//;
84 37         142 return $out;
85             }
86              
87             sub parse_perfstring {
88 29     29 1 10399 my ($class, $perfstring) = @_;
89 29         48 my @perfs = ();
90 29         32 my $obj;
91 29         58 while ($perfstring) {
92 41         151 $perfstring =~ s/^\s*//;
93             # If there is more than 1 equals sign, split it out and parse individually
94 41 100       46 if (@{[$perfstring =~ /=/g]} > 1) {
  41         162  
95 14         59 $perfstring =~ s/^(.*?=.*?)\s//;
96 14 100       32 if (defined $1) {
97 13         24 $obj = $class->_parse($1);
98             } else {
99             # This could occur if perfdata was soemthing=value=
100             # Since this is invalid, we reset the string and continue
101 1         3 $perfstring = "";
102 1         4 $obj = $class->_parse($perfstring);
103             }
104             } else {
105 27         47 $obj = $class->_parse($perfstring);
106 27         39 $perfstring = "";
107             }
108 41 100       99 push @perfs, $obj if $obj;
109             }
110 29         92 return @perfs;
111             }
112              
113             sub rrdlabel {
114 15     15 1 8302 my $self = shift;
115 15         25 my $name = $self->clean_label;
116             # Shorten
117 15         56 return substr( $name, 0, 19 );
118             }
119              
120             sub clean_label {
121 20     20 1 23 my $self = shift;
122 20         367 my $name = $self->label;
123 20 100       112 if ($name eq "/") {
    100          
124 3         3 $name = "root";
125             } elsif ( $name =~ s/^\/// ) {
126 6         17 $name =~ s/\//_/g;
127             }
128             # Convert all other characters
129 20         51 $name =~ s/\W/_/g;
130 20         37 return $name;
131             }
132              
133             # Backward compatibility: create a threshold object on the fly as requested
134             sub threshold
135             {
136 90     90 1 35531 my $self = shift;
137 90         1647 return Monitoring::Plugin::Threshold->set_thresholds(
138             warning => $self->warning, critical => $self->critical
139             );
140             }
141              
142             # Constructor - unpack thresholds, map args to hashref
143             sub new
144             {
145 48     48 1 6077 my $class = shift;
146 48         153 my %arg = @_;
147              
148             # Convert thresholds
149 48 100       96 if (my $threshold = delete $arg{threshold}) {
150 7   66     118 $arg{warning} ||= $threshold->warning . "";
151 7   66     469 $arg{critical} ||= $threshold->critical . "";
152             }
153              
154 48         413 $class->SUPER::new(\%arg);
155             }
156              
157             1;
158              
159             __END__