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 3     3   2572 use 5.006;
  3         60  
4              
5 3     3   17 use strict;
  3         5  
  3         73  
6 3     3   15 use warnings;
  3         4  
  3         103  
7              
8 3     3   20 use Carp;
  3         28  
  3         239  
9 3     3   14 use base qw(Class::Accessor::Fast);
  3         5  
  3         1597  
10             __PACKAGE__->mk_ro_accessors(
11             qw(label value uom warning critical min max)
12             );
13              
14 3     3   6713 use Nagios::Monitoring::Plugin::Functions;
  3         8  
  3         305  
15 3     3   1393 use Nagios::Monitoring::Plugin::Threshold;
  3         10  
  3         26  
16 3     3   81 use Nagios::Monitoring::Plugin::Range;
  3         5  
  3         14  
17             our ($VERSION) = $Nagios::Monitoring::Plugin::Functions::VERSION;
18              
19             sub import {
20 3     3   621 my ($class, %attr) = @_;
21 3   100     23 $_ = $attr{use_die} || 0;
22 3         11 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   69 my $class = shift;
32 41         61 my $string = shift;
33 41         529 $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     373 return undef unless ((defined $1 && $1 ne "") && (defined $2 && $2 ne ""));
      66        
      66        
35 37         203 my @info = ($1, $2, $3, $4, $5, $6, $7);
36             # We convert any commas to periods, in the value fields
37 37 100       63 map { defined $info[$_] && $info[$_] =~ s/,/./go } (1, 3, 4, 5, 6);
  185         644  
38              
39             # Check that $info[1] is an actual value
40             # We do this by returning undef if a warning appears
41 37         43 my $performance_value;
42             {
43 37         44 my $not_value;
  37         37  
44 37     1   203 local $SIG{__WARN__} = sub { $not_value++ };
  1         9  
45 37         104 $performance_value = $info[1]+0;
46 37 100       184 return undef if $not_value;
47             }
48 36         124 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         532 return $p;
53             }
54              
55             # Map undef to ''
56             sub _nvl {
57 185     185   924 my ($self, $value) = @_;
58 185 100       762 defined $value ? $value : ''
59             }
60              
61             sub perfoutput {
62 37     37 1 250 my $self = shift;
63             # Add quotes if label contains a space character
64 37         103 my $label = $self->label;
65 37 100       230 if ($label =~ / /) {
66 2         7 $label = "'$label'";
67             }
68 37         174 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         173 $out =~ s/;;$//;
78 37         212 return $out;
79             }
80              
81             sub parse_perfstring {
82 29     29 1 13114 my ($class, $perfstring) = @_;
83 29         47 my @perfs = ();
84 29         36 my $obj;
85 29         78 while ($perfstring) {
86 41         154 $perfstring =~ s/^\s*//;
87             # If there is more than 1 equals sign, split it out and parse individually
88 41 100       60 if (@{[$perfstring =~ /=/g]} > 1) {
  41         188  
89 14         69 $perfstring =~ s/^(.*?=.*?)\s//;
90 14 100       41 if (defined $1) {
91 13         34 $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         70 $obj = $class->_parse($perfstring);
100 27         46 $perfstring = "";
101             }
102 41 100       8007 push @perfs, $obj if $obj;
103             }
104 29         139 return @perfs;
105             }
106              
107             sub rrdlabel {
108 15     15 1 9005 my $self = shift;
109 15         35 my $name = $self->clean_label;
110             # Shorten
111 15         62 return substr( $name, 0, 19 );
112             }
113              
114             sub clean_label {
115 20     20 1 29 my $self = shift;
116 20         47 my $name = $self->label;
117 20 100       155 if ($name eq "/") {
    100          
118 3         5 $name = "root";
119             } elsif ( $name =~ s/^\/// ) {
120 6         14 $name =~ s/\//_/g;
121             }
122             # Convert all other characters
123 20         65 $name =~ s/\W/_/g;
124 20         50 return $name;
125             }
126              
127             # Backward compatibility: create a threshold object on the fly as requested
128             sub threshold
129             {
130 90     90 1 49203 my $self = shift;
131 90         239 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 13952 my $class = shift;
140 48         271 my %arg = @_;
141              
142             # Convert thresholds
143 48 100       134 if (my $threshold = delete $arg{threshold}) {
144 7   66     37 $arg{warning} ||= $threshold->warning . "";
145 7   66     224 $arg{critical} ||= $threshold->critical . "";
146             }
147              
148 48         281 $class->SUPER::new(\%arg);
149             }
150              
151             1;
152              
153             __END__