File Coverage

blib/lib/Nagios/Monitoring/Plugin/Performance.pm
Criterion Covered Total %
statement 85 85 100.0
branch 22 22 100.0
condition 12 17 70.5
subroutine 18 18 100.0
pod 6 6 100.0
total 143 148 96.6


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