File Coverage

blib/lib/JMX/Jmx4Perl/Nagios/SingleCheck.pm
Criterion Covered Total %
statement 128 404 31.6
branch 39 242 16.1
condition 9 91 9.8
subroutine 23 44 52.2
pod 2 4 50.0
total 201 785 25.6


line stmt bran cond sub pod time code
1             package JMX::Jmx4Perl::Nagios::SingleCheck;
2              
3 1     1   65660 use strict;
  1         3  
  1         33  
4 1     1   8 use warnings;
  1         2  
  1         37  
5 1     1   797 use JMX::Jmx4Perl;
  1         5  
  1         29  
6 1     1   11 use JMX::Jmx4Perl::Request;
  1         2  
  1         84  
7 1     1   737 use JMX::Jmx4Perl::Response;
  1         3  
  1         27  
8 1     1   7 use JMX::Jmx4Perl::Alias;
  1         2  
  1         10  
9 1     1   8 use Data::Dumper;
  1         3  
  1         55  
10 1     1   109 use Nagios::Plugin;
  1         3  
  1         70  
11 1     1   7 use Nagios::Plugin::Functions qw(:codes %STATUS_TEXT);
  1         1  
  1         271  
12 1     1   7 use Carp;
  1         2  
  1         65  
13 1     1   7 use Scalar::Util qw(looks_like_number);
  1         2  
  1         105  
14 1     1   6979 use URI::Escape;
  1         1684  
  1         104  
15 1     1   1137 use Text::ParseWords;
  1         1375  
  1         64  
16 1     1   8 use JSON;
  1         2  
  1         10  
17              
18             our $AUTOLOAD;
19              
20             =head1 NAME
21              
22             JMX::Jmx4Perl::Nagios::SingleCheck - A single nagios check
23              
24             This is an package used internally by
25             L. It encapsulates the configuration for
26             single checks, which can be combined to a bulk JMX-Request so only a single
27             server turnaround is used to obtain multiple checks results at once.
28              
29             =head1 METHODS
30              
31             =over
32              
33             =item $single_check = new $JMX::Jmx4Perl::Nagios::SingleCheck($nagios_plugin,$check_config)
34              
35             Construct a new single check from a given L object
36             C<$nagios_plugin> and a parsed check configuration $check_config, which is a
37             hash.
38              
39             =cut
40              
41             sub new {
42 1     1 1 2 my $class = shift;
43 1   50     5 my $np = shift || die "No Nagios Plugin given";
44 1         2 my $config = shift;
45 1         5 my $self = {
46             np => $np,
47             config => $config
48             };
49 1   33     10 bless $self,(ref($class) || $class);
50 1         6 return $self;
51             }
52              
53             =item $requests = $single_check->get_requests($jmx,$args)
54              
55             Called to obtain an arrayref of L objects which should
56             be send to the server agent. C<$jmx> ist the L agent, C<$args>
57             are additonal arguments used for exec-operations,
58              
59             Multiple request object are returned e.g. if a relative check has to be
60             performed in order to get the base value as well.
61              
62             The returned array can contain coderefs which should be executed directly and
63             its return value should be used in order to perfoorm the check.
64              
65             =cut
66              
67             sub get_requests {
68 0     0 1 0 my $self = shift;
69 0         0 my $jmx = shift;
70 0         0 my $args = shift;
71             # If a script is given, extract a subref and return it
72 0 0       0 return [ $self->_extract_script_as_subref($jmx) ] if $self->script;
73              
74 0   0     0 my $do_read = $self->attribute || $self->value;
75 0         0 my $do_exec = $self->operation;
76 0 0       0 if ($self->alias) {
77 0         0 my $alias = JMX::Jmx4Perl::Alias->by_name($self->alias);
78 0 0       0 die "No alias '",$self->alias," known" unless $alias;
79 0         0 $do_read = $alias->type eq "attribute";
80             }
81 0         0 my @requests = ();
82 0         0 my $request;
83 0 0       0 if ($do_read) {
    0          
84 0         0 $request = JMX::Jmx4Perl::Request->new(READ,$self->_prepare_read_args($jmx));
85             } elsif ($do_exec) {
86 0         0 $request = JMX::Jmx4Perl::Request->new(EXEC,$self->_prepare_exec_args($jmx,@$args));
87             } else {
88 0         0 die "Neither an attribute/value, an operation or a script given";
89             }
90 0   0     0 my $method = $self->{np}->opts->{method} || $self->{config}->{method};
91 0 0       0 if ($method) {
92 0         0 $request->method($method);
93             }
94 0         0 push @requests,$request;
95              
96 0 0 0     0 if ($self->base || $self->base_mbean) {
97 0 0       0 if (!looks_like_number($self->base)) {
98             # It looks like a number, so we will use the base literally
99 0         0 my $alias;
100            
101 0 0       0 if ($self->base) {
102 0         0 $alias = JMX::Jmx4Perl::Alias->by_name($self->base);
103             }
104 0 0       0 if ($alias) {
105 0         0 push @requests,new JMX::Jmx4Perl::Request(READ,$jmx->resolve_alias($self->base));
106             } else {
107 0 0       0 my ($mbean,$attr,$path) = $self->base_mbean ?
108             ($self->base_mbean, $self->base_attribute, $self->base_path) :
109             $self->_split_attr_spec($self->base);
110 0 0       0 die "No MBean given in base name ",$self->base unless $mbean;
111 0 0       0 die "No Attribute given in base name ",$self->base unless $attr;
112            
113 0         0 $mbean = URI::Escape::uri_unescape($mbean);
114 0         0 $attr = URI::Escape::uri_unescape($attr);
115 0 0       0 $path = URI::Escape::uri_unescape($path) if $path;
116 0         0 push @requests,new JMX::Jmx4Perl::Request(READ,$mbean,$attr,$path);
117             }
118             }
119             }
120            
121 0         0 return \@requests;
122             }
123              
124             # Create a subref where all params from the outside are available as closures.
125             sub _extract_script_as_subref {
126 0     0   0 my $self = shift;
127 0         0 my $jmx = shift;
128 0   0     0 my $script = $self->script || die "No script given";
129 0         0 my $full_script = <<"EOT";
130             sub {
131             my \$j4p = shift;
132             return sub {
133             $script
134             }
135             }
136             EOT
137             #print $full_script,"\n";
138 0         0 my $sub = eval $full_script;
139 0 0       0 die "Cannot eval script for check ",$self->name,": $@" if $@;
140 0         0 return &$sub($jmx);
141             }
142              
143             =item $single_check->exract_responses($responses,$requests,$target)
144              
145             Extract L objects and add the deducted results to
146             the nagios plugin (which was given at construction time).
147              
148             C<$responses> is an arrayref to the returned responses, C<$requests> is an
149             arrayref to the original requests. Any response consumed from C<$requests>
150             should be removed from the array, as well as the corresponding request.
151             The requests/responses for this single request are always a the beginning of
152             the arrays.
153              
154             C<$target> is an optional target configuration if the request was used in
155             target proxy mode.
156              
157             =cut
158              
159             sub extract_responses {
160 0     0 0 0 my $self = shift;
161 0         0 my $responses = shift;
162 0         0 my $requests = shift;
163 0   0     0 my $opts = shift || {};
164 0         0 my $np = $self->{np};
165 0   0     0 my $msg_handler = $np->{msg_handler} || $np;
166              
167             # Get response/request pair
168 0         0 my $resp = shift @{$responses};
  0         0  
169 0         0 my $request = shift @{$requests};
  0         0  
170             #print Dumper($resp);
171 0         0 my @extra_requests = ();
172 0         0 my $value;
173 0         0 my $script_mode = undef;
174 0 0       0 if (ref($request) eq "CODE") {
175             # It's a script, so the 'response' is already the value
176 0         0 $script_mode = 1;
177 0         0 $value = $resp;
178             } else {
179 0         0 $self->_verify_response($request,$resp);
180 0         0 $value = $self->_extract_value($request,$resp);
181             }
182            
183             # Delta handling
184 0         0 my $delta = $self->delta;
185 0 0 0     0 if (defined($delta) && !$script_mode) {
186 0         0 $value = $self->_delta_value($request,$resp,$delta);
187 0 0       0 unless (defined($value)) {
188 0         0 push @extra_requests,$self->_switch_on_history($request,$opts->{target});
189 0         0 $value = 0;
190             }
191             }
192            
193             # Normalize value
194 0         0 my ($value_conv,$unit) = $self->_normalize_value($value);
195 0         0 my $label = $self->_get_name(cleanup => 1);
196 0 0 0     0 if ( ($self->base || $self->base_mbean) && !$script_mode) {
      0        
197             # Calc relative value
198 0         0 my $base_value = $self->_base_value($self->base,$responses,$requests);
199 0 0       0 my $rel_value = sprintf "%2.2f",$base_value ? (int((($value / $base_value) * 10000) + 0.5) / 100) : 0;
200            
201             # Performance data. Convert to absolute values before
202 0 0       0 if ($self->_include_perf_data) {
203 0 0 0     0 if ($self->perfdata && $self->perfdata =~ /^\s*\%\s*/) {
204 0         0 $np->add_perfdata(label => $label, value => $rel_value, uom => '%',
205             critical => $self->critical, warning => $self->warning);
206             } else {
207 0         0 my ($critical,$warning) = $self->_convert_relative_to_absolute($base_value,$self->critical,$self->warning);
208 0 0       0 $np->add_perfdata(label => $label,value => $value,
209             critical => $critical,warning => $warning,
210             min => 0,max => $base_value,
211             $self->unit ? (uom => $self->unit) : ());
212             }
213             }
214             # Do the real check.
215 0         0 my ($code,$mode) = $self->_check_threshold($rel_value);
216             # For Multichecks, we remember the label of a currently failed check
217 0 0       0 $self->update_error_stats($opts->{error_stat},$code) unless $code == OK;
218 0         0 my ($base_conv,$base_unit) = $self->_normalize_value($base_value);
219 0         0 $msg_handler->add_message($code,$self->_exit_message(code => $code,mode => $mode,rel_value => $rel_value,
220             value => $value_conv, unit => $unit, base => $base_conv,
221             base_unit => $base_unit, prefix => $opts->{prefix}));
222             } else {
223             # Performance data
224 0         0 $value = $self->_sanitize_value($value);
225 0 0       0 if ($self->_include_perf_data) {
226 0 0       0 $np->add_perfdata(label => $label,
227             critical => $self->critical, warning => $self->warning,
228             value => $value,$self->unit ? (uom => $self->unit) : ());
229             }
230            
231             # Do the real check.
232 0         0 my ($code,$mode) = $self->_check_threshold($value);
233 0 0       0 $self->update_error_stats($opts->{error_stat},$code) unless $code == OK;
234 0         0 $msg_handler->add_message($code,$self->_exit_message(code => $code,mode => $mode,value => $value_conv, unit => $unit,
235             prefix => $opts->{prefix}));
236             }
237 0         0 return @extra_requests;
238             }
239              
240             sub _include_perf_data {
241 0     0   0 my $self = shift;
242             # No perf dara for string based checks by default
243 0         0 my $default = not defined($self->string);
244             # If 'PerfData' is set explicitely to false/off/no/0 then no perfdata
245             # will be included
246 0 0       0 return $default unless defined($self->perfdata);
247 0         0 return $self->perfdata !~ /^\s*(false|off|no|0)\s*$/i;
248             }
249              
250             sub update_error_stats {
251 0     0 0 0 my $self = shift;
252 0   0     0 my $error_stat = shift || return;
253 0         0 my $code = shift;
254              
255 0   0     0 my $label = $self->{config}->{name} || $self->{config}->{key};
256 0 0       0 if ($label) {
257 0   0     0 my $arr = $error_stat->{$code} || [];
258 0         0 push @$arr,$label;
259 0         0 $error_stat->{$code} = $arr;
260             }
261             }
262              
263             # Extract a single value, which is different, if the request was a pattern read
264             # request
265             sub _extract_value {
266 0     0   0 my $self = shift;
267 0         0 my $req = shift;
268 0         0 my $resp = shift;
269 0 0 0     0 if ($req->get('type') eq READ && $req->is_mbean_pattern) {
270 0         0 return $self->_extract_value_from_pattern_request($resp->value);
271             } else {
272 0         0 return $self->_null_safe_value($resp->value);
273             }
274             }
275              
276             sub _null_safe_value {
277 0     0   0 my $self = shift;
278 0         0 my $value = shift;
279 0 0       0 if (defined($value)) {
280 0 0 0     0 if (JSON::is_bool($value)) {
    0          
281 0         0 return "$value";
282             } elsif (ref($value) && $self->string) {
283             # We can deal with complex values withing string comparison
284 0 0       0 if (ref($value) eq "ARRAY") {
285 0         0 return join ",",@{$value};
  0         0  
286             } else {
287 0         0 return Dumper($value);
288             }
289             } else {
290 0         0 return $value;
291             }
292             } else {
293             # Our null value
294 0 0       0 return defined($self->null) ? $self->null : "null";
295             }
296             }
297              
298             sub _extract_value_from_pattern_request {
299 0     0   0 my $self = shift;
300 0         0 my $val = shift;
301 0         0 my $np = $self->{np};
302 0 0       0 $self->_die("Pattern request does not result in a proper return format: " . Dumper($val))
303             if (ref($val) ne "HASH");
304 0 0       0 $self->_die("More than one MBean found for a pattern request: " . Dumper([keys %$val])) if keys %$val != 1;
305 0         0 my $attr_val = (values(%$val))[0];
306 0 0       0 $self->_die("Invalid response for pattern match: " . Dumper($attr_val)) unless ref($attr_val) eq "HASH";
307 0 0       0 $self->_die("Only a single attribute can be used. Given: " . Dumper([keys %$attr_val])) if keys %$attr_val != 1;
308 0         0 return $self->_null_safe_value((values(%$attr_val))[0]);
309             }
310              
311             sub _delta_value {
312 0     0   0 my ($self,$req,$resp,$delta) = @_;
313            
314 0         0 my $history = $resp->history;
315 0 0       0 if (!$history) {
316             # No delta on the first run
317 0         0 return undef;
318             } else {
319 0         0 my $hist_val;
320 0 0       0 if ($req->is_mbean_pattern) {
321 0         0 $hist_val = $self->_extract_value_from_pattern_request($history);
322             } else {
323 0         0 $hist_val = $history;
324             }
325 0 0       0 if (!@$hist_val) {
326             # Can happen in some scenarios when requesting the first history entry,
327             # we return 0 here
328 0         0 return 0;
329             }
330 0         0 my $old_value = $hist_val->[0]->{value};
331 0         0 my $old_time = $hist_val->[0]->{timestamp};
332 0         0 my $value = $self->_extract_value($req,$resp);
333 0 0       0 if ($delta) {
334             # Time average
335 0         0 my $time_delta = $resp->timestamp - $old_time;
336 0 0       0 return (($value - $old_value) / ($time_delta ? $time_delta : 1)) * $delta;
337             } else {
338 0         0 return $value - $old_value;
339             }
340             }
341             }
342              
343             sub _switch_on_history {
344 0     0   0 my ($self,$orig_request,$target) = @_;
345 0         0 my ($mbean,$operation) = ("jolokia:type=Config","setHistoryEntriesForAttribute");
346             # Set history to 1 (we need only the last)
347 0 0       0 return new JMX::Jmx4Perl::Request
348             (EXEC,$mbean,$operation,
349             $orig_request->get("mbean"),$orig_request->get("attribute"),$orig_request->get("path"),
350             $target ? $target->{url} : undef,1,{target => undef});
351             }
352              
353              
354             sub _base_value {
355 0     0   0 my $self = shift;
356 0         0 my $np = $self->{np};
357 0         0 my $name = shift;
358 0         0 my $responses = shift;
359 0         0 my $requests = shift;
360              
361 0 0       0 if (looks_like_number($name)) {
362             # It looks like a number, so we suppose its the base value itself
363 0         0 return $name;
364             }
365 0         0 my $resp = shift @{$responses};
  0         0  
366 0         0 my $req = shift @{$requests};
  0         0  
367 0 0       0 $self->_die($resp->{error}) if $resp->{error};
368             #print Dumper($req,$resp);
369 0         0 return $self->_extract_value($req,$resp);
370             }
371              
372             # Normalize value if a unit-of-measurement is given.
373              
374             # Units and how to convert from one level to the next
375             my @UNITS = ([ qw(ns us ms s m h d) ],[qw(B KB MB GB TB)]);
376             my %UNITS =
377             (
378             ns => 1,
379             us => 10**3,
380             ms => 10**3,
381             s => 10**3,
382             m => 60,
383             h => 60,
384             d => 24,
385              
386             B => 1,
387             KB => 2**10,
388             MB => 2**10,
389             GB => 2**10,
390             TB => 2**10
391             );
392              
393             sub _normalize_value {
394 13     13   13662 my $self = shift;
395 13         23 my $value = shift;
396 13   50     44 my $unit = shift || $self->unit || return ($value,undef);
397            
398 13         27 for my $units (@UNITS) {
399 17         21 for my $i (0 .. $#{$units}) {
  17         48  
400 72 100       173 next unless $units->[$i] eq $unit;
401 13         18 my $ret = $value;
402 13         13 my $u = $unit;
403 13 100       36 if (abs($ret) > 1) {
404             # Go up the scale ...
405 8 100       11 return ($value,$unit) if $i == $#{$units};
  8         30  
406 6         12 for my $j ($i+1 .. $#{$units}) {
  6         14  
407 12 100       43 if (abs($ret / $UNITS{$units->[$j]}) >= 1) {
408 6         11 $ret /= $UNITS{$units->[$j]};
409 6         13 $u = $units->[$j];
410             } else {
411 6         30 return ($ret,$u);
412             }
413             }
414             } else {
415             # Go down the scale ...
416 5 50       13 return ($value,$unit) if $i == 0;
417 5         19 for my $j (reverse(0 .. $i-1)) {
418 8 100       19 if ($ret < 1) {
419 5         16 $ret *= $UNITS{$units->[$j+1]};
420 5         15 $u = $units->[$j];
421             } else {
422 3         15 return ($ret,$u);
423             }
424             }
425            
426             }
427 2         10 return ($ret,$u);
428             }
429             }
430 0         0 die "Unknown unit '$unit' for value $value";
431             }
432              
433             sub _sanitize_value {
434 0     0   0 my ($self,$value) = @_;
435 0 0       0 if ($value =~ /\de/i) {
436 0         0 $value = sprintf("%f", $value);
437             }
438 0         0 return $value;
439             }
440              
441             sub _verify_response {
442 0     0   0 my ($self,$req,$resp) = @_;
443 0         0 my $np = $self->{np};
444 0 0       0 if ($resp->is_error) {
445 0         0 my $extra = "";
446 0 0       0 if ($np->opts->{verbose}) {
447 0         0 my $stacktrace = $resp->stacktrace;
448 0 0       0 $extra = ref($stacktrace) eq "ARRAY" ? join "\n",@$stacktrace : $stacktrace if $stacktrace;
    0          
449             }
450 0         0 $self->_die("Error: ".$resp->status." ".$resp->error_text.$extra);
451             }
452            
453 0 0 0     0 if (!$req->is_mbean_pattern && (ref($resp->value) && !$self->string) && !JSON::is_bool($resp->value)) {
      0        
      0        
454 0         0 $self->_die("Response value is a " . ref($resp->value) .
455             ", not a plain value. Did you forget a --path parameter ?". " Value: " .
456             Dumper($resp->value));
457             }
458             }
459              
460             sub _get_name {
461 1     1   3 my $self = shift;
462 1         3 my $args = { @_ };
463 1         3 my $name = $args->{name};
464 1 50       5 if (!$name) {
465 1 50       7 if ($self->name) {
466 1         21 $name = $self->name;
467             } else {
468             # Default name, tried to be generated from various parts
469 0 0       0 if ($self->alias) {
470 0 0       0 $name = "[".$self->alias.($self->path ? "," . $self->path : "") ."]";
471             } else {
472 0         0 my $val = $self->value;
473 0 0       0 if ($val) {
474 0         0 $name = "[" . $val . "]";
475             } else {
476 0   0     0 my $a_or_o = $self->attribute || $self->operation || "";
477 0 0       0 my $p = $self->path ? "," . $self->path : "";
478 0         0 $name = "[" . $self->mbean . "," . $a_or_o . $p . "]";
479             }
480             }
481             }
482             }
483 1 50       17 if ($args->{cleanup}) {
484             # Enable this when '=' gets forbidden
485 0         0 $name =~ s/=/#/g;
486             }
487             # Prepare label for usage with Nagios::Plugin, which will blindly
488             # add quotes if a space is contained in the label.
489             # We are doing the escape of quotes ourself here
490 1         3 $name =~ s/'/''/g;
491 1         7 return $name;
492             }
493              
494             sub _prepare_read_args {
495 0     0   0 my $self = shift;
496 0         0 my $np = $self->{np};
497 0         0 my $jmx = shift;
498              
499 0 0       0 if ($self->alias) {
    0          
500 0         0 my @req_args = $jmx->resolve_alias($self->alias);
501 0 0       0 $self->_die("Cannot resolve attribute alias ",$self->alias()) unless @req_args > 0;
502 0 0       0 if ($self->path) {
503 0 0       0 @req_args == 2 ? $req_args[2] = $self->path : $req_args[2] .= "/" . $self->path;
504             }
505 0         0 return @req_args;
506             } elsif ($self->value) {
507 0         0 return $self->_split_attr_spec($self->value);
508             } else {
509 0         0 return ($self->mbean,$self->attribute,$self->path);
510             }
511             }
512              
513             sub _prepare_exec_args {
514 0     0   0 my $self = shift;
515 0         0 my $np = $self->{np};
516 0         0 my $jmx = shift;
517              
518             # Merge CLI arguments and arguments from the configuration,
519             # with CLI arguments taking precedence
520 0         0 my @cli_args = @_;
521 0         0 my $config_args = $self->{config}->{argument};
522            
523 0 0 0     0 $config_args = [ $config_args ] if defined($config_args) && !ref($config_args) eq "ARRAY";
524 0         0 my @args = ();
525 0 0       0 if ($config_args) {
526 0         0 my @c_args = (@$config_args);
527 0   0     0 while (@cli_args || @c_args) {
528 0         0 my $cli_arg = shift @cli_args;
529 0         0 my $config_arg = shift @c_args;
530 0 0       0 push @args, defined($cli_arg) ? $cli_arg : $config_arg;
531             }
532             } else {
533 0         0 @args = @cli_args;
534             }
535 0 0       0 if ($self->alias) {
536 0         0 my @req_args = $jmx->resolve_alias($self->alias);
537 0 0       0 $self->_die("Cannot resolve operation alias ",$self->alias()) unless @req_args >= 2;
538 0         0 return (@req_args,@args);
539             } else {
540 0         0 return ($self->mbean,$self->operation,@args);
541             }
542             }
543              
544             sub _split_attr_spec {
545 0     0   0 my $self = shift;
546 0         0 my $name = shift;
547 0         0 my @ret = ();
548             # Text:ParseWords is used for split on "/" taking into account
549             # quoting and escaping
550 0         0 for my $p (parse_line("/",1,$name)) {
551             # We need to 'unescape' things ourselves
552             # since we want quotes to remain in the names (using '0'
553             # above would kill those quotes, too).
554 0         0 $p =~ s|\\(.)|$1|sg;
555 0         0 push @ret,$p;
556             }
557 0 0       0 return (shift(@ret),shift(@ret),@ret ? join("/",@ret) : undef);
558             }
559              
560             sub _check_threshold {
561 0     0   0 my $self = shift;
562 0         0 my $value = shift;
563 0         0 my $np = $self->{np};
564 0         0 my $numeric_check;
565 0 0 0     0 if ($self->numeric || $self->string) {
566 0 0       0 $numeric_check = $self->numeric ? 1 : 0;
567             } else {
568 0         0 $numeric_check = looks_like_number($value);
569             }
570 0 0       0 if ($numeric_check) {
571             # Verify numeric thresholds
572 0 0       0 my @ths =
    0          
573             (
574             defined($self->critical) ? (critical => $self->critical) : (),
575             defined($self->warning) ? (warning => $self->warning) : ()
576             );
577             #print Dumper({check => $value,@ths});
578 0 0       0 return (@ths ? $np->check_threshold(check => $value,@ths) : OK,"numeric");
579             } else {
580             return
581 0 0 0     0 ($self->_check_string_threshold($value,CRITICAL,$self->critical) ||
582             $self->_check_string_threshold($value,WARNING,$self->warning) ||
583             OK,
584             $value =~ /^true|false$/i ? "boolean" : "string");
585             }
586             }
587              
588             sub _check_string_threshold {
589 0     0   0 my $self = shift;
590 0         0 my ($value,$level,$check_value) = @_;
591 0 0       0 return undef unless $check_value;
592 0 0       0 if ($check_value =~ m|^\s*qr(.)(.*)\1\s*$|) {
593 0 0       0 return $value =~ m/$2/ ? $level : undef;
594             }
595 0 0       0 if ($check_value =~ s/^\!//) {
596 0 0       0 return $value ne $check_value ? $level : undef;
597             } else {
598 0 0       0 return $value eq $check_value ? $level : undef;
599             }
600             }
601              
602             sub _convert_relative_to_absolute {
603 0     0   0 my $self = shift;
604 0         0 my ($base_value,@to_convert) = @_;
605 0         0 my @ret = ();
606 0         0 for my $v (@to_convert) {
607 0 0       0 $v =~ s|([\d\.]+)|($1 / 100) * $base_value|eg if $v;
  0         0  
608 0         0 push @ret,$v;
609             }
610 0         0 return @ret;
611             }
612              
613             # Prepare an exit message depending on the result of
614             # the check itself. Quite evolved, you can overwrite this always via '--label'.
615             sub _exit_message {
616 1     1   1125 my $self = shift;
617 1         8 my $args = { @_ };
618             # Custom label has precedence
619 1 50       18 return $self->_format_label($self->label,$args) if $self->label;
620              
621 1         2 my $code = $args->{code};
622 1         4 my $mode = $args->{mode};
623 1 50 33     10 if ($code == CRITICAL || $code == WARNING) {
624 0 0 0     0 if ($self->base || $self->base_mbean) {
625 0         0 return $self->_format_label
626             ('%n : Threshold \'%t\' failed for value %.2r% ('. &_placeholder($args,"v") .' %u / '.
627             &_placeholder($args,"b") . ' %u)',$args);
628             } else {
629 0 0       0 if ($mode ne "numeric") {
630 0         0 return $self->_format_label('%n : \'%v\' matches threshold \'%t\'',$args);
631             } else {
632 0         0 return $self->_format_label
633             ('%n : Threshold \'%t\' failed for value '.&_placeholder($args,"v").' %u',$args);
634             }
635             }
636             } else {
637 1 50 33     10 if ($self->base || $self->base_mbean) {
638 0         0 return $self->_format_label('%n : In range %.2r% ('. &_placeholder($args,"v") .' %u / '.
639             &_placeholder($args,"b") . ' %w)',$args);
640             } else {
641 1 50       9 if ($mode ne "numeric") {
642 0         0 return $self->_format_label('%n : \'%v\' as expected',$args);
643             } else {
644 1         6 return $self->_format_label('%n : Value '.&_placeholder($args,"v").' %u in range',$args);
645             }
646             }
647              
648             }
649             }
650              
651             sub _placeholder {
652 1     1   4 my ($args,$c) = @_;
653 1         2 my $val;
654 1 50       5 if ($c eq "v") {
655 1         4 $val = $args->{value};
656             } else {
657 0         0 $val = $args->{base};
658             }
659 1 50       17 return ($val =~ /\./ ? "%.2" : "%") . $c;
660             }
661              
662             sub _format_label {
663 1     1   3 my $self = shift;
664 1         3 my $label = shift;
665 1         4 my $args = shift;
666             # %r : relative value (as percent)
667             # %q : relative value (as floating point)
668             # %v : value
669             # %f : value as floating point
670             # %u : unit
671             # %b : base value
672             # %w : base unit
673             # %t : threshold failed ("" for OK or UNKNOWN)
674             # %c : code ("OK", "WARNING", "CRITICAL", "UNKNOWN")
675             # %d : delta
676             #
677 1         12 my @parts = split /(\%[\w\.\-]*\w)/,$label;
678 1         3 my $ret = "";
679 1         3 foreach my $p (@parts) {
680 7 100       27 if ($p =~ /^(\%[\w\.\-]*)(\w)$/) {
681 3         9 my ($format,$what) = ($1,$2);
682 3 50 33     67 if ($what eq "r" || $what eq "q") {
    50 66        
    100          
    50          
    100          
    50          
    50          
    50          
    0          
    0          
    0          
683 0   0     0 my $val = $args->{rel_value} || 0;
684 0 0       0 $val = $what eq "r" ? $val : $val / 100;
685 0         0 $ret .= sprintf $format . "f",$val;
686             } elsif ($what eq "b") {
687 0   0     0 $ret .= sprintf $format . &_format_char($args->{base}),($args->{base} || 0);
688             } elsif ($what eq "u" || $what eq "w") {
689 1   50     9 $ret .= sprintf $format . "s",($what eq "u" ? $args->{unit} : $args->{base_unit}) || "";
690 1         4 $ret =~ s/\s$//;
691             } elsif ($what eq "f") {
692 0         0 $ret .= sprintf $format . "f",$args->{value};
693             } elsif ($what eq "v") {
694 1         7 $ret .= &_format_value($format,$args->{mode},$args->{value});
695             } elsif ($what eq "t") {
696 0         0 my $code = $args->{code};
697 0 0       0 my $val = $code == CRITICAL ? $self->critical : ($code == WARNING ? $self->warning : "");
    0          
698 0 0       0 $ret .= sprintf $format . "s",defined($val) ? $val : "";
699             } elsif ($what eq "c") {
700 0         0 $ret .= sprintf $format . "s",$STATUS_TEXT{$args->{code}};
701             } elsif ($what eq "n") {
702 1         9 $ret .= sprintf $format . "s",$self->_get_name();
703             } elsif ($what eq "d") {
704 0         0 $ret .= sprintf $format . "d",$self->delta;
705             } elsif ($what eq "y") {
706 0         0 $ret .= &_format_value($format,$args->{mode},$self->warning);
707             } elsif ($what eq "z") {
708 0         0 $ret .= &_format_value($format,$args->{mode},$self->critical);
709             }
710             } else {
711 4         9 $ret .= $p;
712             }
713             }
714 1 50       8 if ($args->{prefix}) {
715 0         0 my $prefix = $args->{prefix};
716 0         0 $prefix =~ s/\%c/$STATUS_TEXT{$args->{code}}/g;
717 0         0 return $prefix . $ret;
718             } else {
719 1         9 return $ret;
720             }
721             }
722              
723             sub _format_value {
724 1     1   3 my $format = shift;
725 1         2 my $mode = shift;
726 1         3 my $value = shift;
727 1 50       5 if ($mode ne "numeric") {
728 0         0 return sprintf $format . "s",$value;
729             } else {
730 1         4 return sprintf $format . &_format_char($value),$value;
731             }
732             }
733             sub _format_char {
734 1     1   10 my $val = shift;
735 1 50       20 $val =~ /\./ ? "f" : "d";
736             }
737              
738             sub _die {
739 0     0   0 my $self = shift;
740 0         0 my $msg = join("",@_);
741 0         0 die $msg,"\n";
742             }
743              
744             my $CHECK_CONFIG_KEYS = {
745             "critical" => "critical",
746             "warning" => "warning",
747             "mbean" => "mbean",
748             "attribute" => "attribute",
749             "operation" => "operation",
750             "alias" => "alias",
751             "path" => "path",
752             "delta" => "delta",
753             "name" => "name",
754             "base" => "base",
755             "base-mbean" => "basembean",
756             "base-attribute" => "baseattribute",
757             "base-path" => "basepath",
758             "unit" => "unit",
759             "numeric" => "numeric",
760             "string" => "string",
761             "label" => "label",
762             "perfdata" => "perfdata",
763             "value" => "value",
764             "null" => "null",
765             "script" => "script"
766             };
767              
768              
769             # Get the proper configuration values
770              
771             sub AUTOLOAD {
772 9     9   49 my $self = shift;
773 9         20 my $np = $self->{np};
774 9         14 my $name = $AUTOLOAD;
775 9         36 $name =~ s/.*://; # strip fully-qualified portion
776 9         20 $name =~ s/_/-/g;
777              
778 9 50       24 if ($CHECK_CONFIG_KEYS->{$name}) {
779 9 100       32 return $np->opts->{$name} if defined($np->opts->{$name});
780 3 50       29 if ($self->{config}) {
781 0         0 return $self->{config}->{$CHECK_CONFIG_KEYS->{$name}};
782             } else {
783 3         39 return undef;
784             }
785             } else {
786 0           $self->_die("No config attribute \"" . $name . "\" known");
787             }
788             }
789              
790              
791             # To keep autoload happy
792 0     0     sub DESTROY {
793              
794             }
795              
796             =back
797              
798             =head1 LICENSE
799              
800             This file is part of jmx4perl.
801              
802             Jmx4perl is free software: you can redistribute it and/or modify
803             it under the terms of the GNU General Public License as published by
804             the Free Software Foundation, either version 2 of the License, or
805             (at your option) any later version.
806              
807             jmx4perl is distributed in the hope that it will be useful,
808             but WITHOUT ANY WARRANTY; without even the implied warranty of
809             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
810             GNU General Public License for more details.
811              
812             You should have received a copy of the GNU General Public License
813             along with jmx4perl. If not, see .
814              
815             =head1 AUTHOR
816              
817             roland@cpan.org
818              
819             =cut
820              
821             1;