File Coverage

blib/lib/JMX/Jmx4Perl/Nagios/SingleCheck.pm
Criterion Covered Total %
statement 128 403 31.7
branch 39 244 15.9
condition 9 91 9.8
subroutine 23 44 52.2
pod 2 4 50.0
total 201 786 25.5


line stmt bran cond sub pod time code
1             package JMX::Jmx4Perl::Nagios::SingleCheck;
2              
3 1     1   66304 use strict;
  1         1  
  1         22  
4 1     1   5 use warnings;
  1         3  
  1         23  
5 1     1   656 use JMX::Jmx4Perl;
  1         3  
  1         35  
6 1     1   7 use JMX::Jmx4Perl::Request;
  1         3  
  1         84  
7 1     1   735 use JMX::Jmx4Perl::Response;
  1         3  
  1         34  
8 1     1   6 use JMX::Jmx4Perl::Alias;
  1         2  
  1         10  
9 1     1   7 use Data::Dumper;
  1         2  
  1         57  
10 1     1   96 use Monitoring::Plugin;
  1         2  
  1         80  
11 1     1   5 use Monitoring::Plugin::Functions qw(:codes %STATUS_TEXT);
  1         2  
  1         233  
12 1     1   5 use Carp;
  1         2  
  1         78  
13 1     1   7 use Scalar::Util qw(looks_like_number);
  1         3  
  1         58  
14 1     1   820 use URI::Escape;
  1         1678  
  1         73  
15 1     1   919 use Text::ParseWords;
  1         1500  
  1         80  
16 1     1   7 use JSON;
  1         1  
  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 3 my $class = shift;
43 1   50     5 my $np = shift || die "No Nagios Plugin given";
44 1         2 my $config = shift;
45 1         4 my $self = {
46             np => $np,
47             config => $config
48             };
49 1   33     13 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             # Delta handling
183 0         0 my $delta = $self->delta;
184 0 0 0     0 if (defined($delta) && !$script_mode) {
185 0         0 $value = $self->_delta_value($request,$resp,$delta);
186 0 0       0 unless (defined($value)) {
187 0         0 push @extra_requests,$self->_switch_on_history($request,$opts->{target});
188 0         0 $value = 0;
189             }
190             }
191            
192             # Normalize value
193 0         0 my ($value_conv,$unit) = $self->_normalize_value($value);
194 0         0 my $label = $self->_get_name(cleanup => 1);
195 0 0 0     0 if ( ($self->base || $self->base_mbean) && !$script_mode) {
      0        
196             # Calc relative value
197 0         0 my $base_value = $self->_base_value($self->base,$responses,$requests);
198 0 0       0 my $rel_value = sprintf "%2.2f",$base_value ? (int((($value / $base_value) * 10000) + 0.5) / 100) : 0;
199            
200             # Performance data. Convert to absolute values before
201 0 0       0 if ($self->_include_perf_data) {
202 0 0 0     0 if ($self->perfdata && $self->perfdata =~ /^\s*\%\s*/) {
203 0         0 $np->add_perfdata(label => $label, value => $rel_value, uom => '%',
204             critical => $self->critical, warning => $self->warning);
205             } else {
206 0         0 my ($critical,$warning) = $self->_convert_relative_to_absolute($base_value,$self->critical,$self->warning);
207 0 0       0 $np->add_perfdata(label => $label,value => $value,
208             critical => $critical,warning => $warning,
209             min => 0,max => $base_value,
210             $self->unit ? (uom => $self->unit) : ());
211             }
212             }
213             # Do the real check.
214 0         0 my ($code,$mode) = $self->_check_threshold($rel_value);
215             # For Multichecks, we remember the label of a currently failed check
216 0 0       0 $self->update_error_stats($opts->{error_stat},$code) unless $code == OK;
217 0         0 my ($base_conv,$base_unit) = $self->_normalize_value($base_value);
218             $msg_handler->add_message($code,$self->_exit_message(code => $code,mode => $mode,rel_value => $rel_value,
219             value => $value_conv, unit => $unit, base => $base_conv,
220 0         0 base_unit => $base_unit, prefix => $opts->{prefix}));
221             } else {
222             # Performance data
223 0         0 $value = $self->_sanitize_value($value);
224 0 0       0 if ($self->_include_perf_data) {
225 0 0       0 $np->add_perfdata(label => $label,
226             critical => $self->critical, warning => $self->warning,
227             value => $value,$self->unit ? (uom => $self->unit) : ());
228             }
229            
230             # Do the real check.
231 0         0 my ($code,$mode) = $self->_check_threshold($value);
232 0 0       0 $self->update_error_stats($opts->{error_stat},$code) unless $code == OK;
233             $msg_handler->add_message($code,$self->_exit_message(code => $code,mode => $mode,value => $value_conv, unit => $unit,
234 0         0 prefix => $opts->{prefix}));
235             }
236 0         0 return @extra_requests;
237             }
238              
239             sub _include_perf_data {
240 0     0   0 my $self = shift;
241             # No perf dara for string based checks by default
242 0         0 my $default = not defined($self->string);
243             # If 'PerfData' is set explicitely to false/off/no/0 then no perfdata
244             # will be included
245 0 0       0 return $default unless defined($self->perfdata);
246 0         0 return $self->perfdata !~ /^\s*(false|off|no|0)\s*$/i;
247             }
248              
249             sub update_error_stats {
250 0     0 0 0 my $self = shift;
251 0   0     0 my $error_stat = shift || return;
252 0         0 my $code = shift;
253              
254 0   0     0 my $label = $self->{config}->{name} || $self->{config}->{key};
255 0 0       0 if ($label) {
256 0   0     0 my $arr = $error_stat->{$code} || [];
257 0         0 push @$arr,$label;
258 0         0 $error_stat->{$code} = $arr;
259             }
260             }
261              
262             # Extract a single value, which is different, if the request was a pattern read
263             # request
264             sub _extract_value {
265 0     0   0 my $self = shift;
266 0         0 my $req = shift;
267 0         0 my $resp = shift;
268 0 0 0     0 if ($req->get('type') eq READ && $req->is_mbean_pattern) {
269 0         0 return $self->_extract_value_from_pattern_request($resp->value);
270             } else {
271 0         0 return $self->_null_safe_value($resp->value);
272             }
273             }
274              
275             sub _null_safe_value {
276 0     0   0 my $self = shift;
277 0         0 my $value = shift;
278 0 0       0 if (defined($value)) {
279 0 0 0     0 if (JSON::is_bool($value)) {
    0          
280 0 0       0 return $value ? "true" : "false";
281             } elsif (ref($value) && $self->string) {
282             # We can deal with complex values withing string comparison
283 0 0       0 if (ref($value) eq "ARRAY") {
284 0         0 return join ",",@{$value};
  0         0  
285             } else {
286 0         0 return Dumper($value);
287             }
288             } else {
289 0         0 return $value;
290             }
291             } else {
292             # Our null value
293 0 0       0 return defined($self->null) ? $self->null : "null";
294             }
295             }
296              
297             sub _extract_value_from_pattern_request {
298 0     0   0 my $self = shift;
299 0         0 my $val = shift;
300 0         0 my $np = $self->{np};
301 0 0       0 $self->_die("Pattern request does not result in a proper return format: " . Dumper($val))
302             if (ref($val) ne "HASH");
303 0 0       0 $self->_die("More than one MBean found for a pattern request: " . Dumper([keys %$val])) if keys %$val != 1;
304 0         0 my $attr_val = (values(%$val))[0];
305 0 0       0 $self->_die("Invalid response for pattern match: " . Dumper($attr_val)) unless ref($attr_val) eq "HASH";
306 0 0       0 $self->_die("Only a single attribute can be used. Given: " . Dumper([keys %$attr_val])) if keys %$attr_val != 1;
307 0         0 return $self->_null_safe_value((values(%$attr_val))[0]);
308             }
309              
310             sub _delta_value {
311 0     0   0 my ($self,$req,$resp,$delta) = @_;
312            
313 0         0 my $history = $resp->history;
314 0 0       0 if (!$history) {
315             # No delta on the first run
316 0         0 return undef;
317             } else {
318 0         0 my $hist_val;
319 0 0       0 if ($req->is_mbean_pattern) {
320 0         0 $hist_val = $self->_extract_value_from_pattern_request($history);
321             } else {
322 0         0 $hist_val = $history;
323             }
324 0 0       0 if (!@$hist_val) {
325             # Can happen in some scenarios when requesting the first history entry,
326             # we return 0 here
327 0         0 return 0;
328             }
329 0         0 my $old_value = $hist_val->[0]->{value};
330 0         0 my $old_time = $hist_val->[0]->{timestamp};
331 0         0 my $value = $self->_extract_value($req,$resp);
332 0 0       0 if ($delta) {
333             # Time average
334 0         0 my $time_delta = $resp->timestamp - $old_time;
335 0 0       0 return (($value - $old_value) / ($time_delta ? $time_delta : 1)) * $delta;
336             } else {
337 0         0 return $value - $old_value;
338             }
339             }
340             }
341              
342             sub _switch_on_history {
343 0     0   0 my ($self,$orig_request,$target) = @_;
344 0         0 my ($mbean,$operation) = ("jolokia:type=Config","setHistoryEntriesForAttribute");
345             # Set history to 1 (we need only the last)
346             return new JMX::Jmx4Perl::Request
347             (EXEC,$mbean,$operation,
348             $orig_request->get("mbean"),$orig_request->get("attribute"),$orig_request->get("path"),
349 0 0       0 $target ? $target->{url} : undef,1,{target => undef});
350             }
351              
352              
353             sub _base_value {
354 0     0   0 my $self = shift;
355 0         0 my $np = $self->{np};
356 0         0 my $name = shift;
357 0         0 my $responses = shift;
358 0         0 my $requests = shift;
359              
360 0 0       0 if (looks_like_number($name)) {
361             # It looks like a number, so we suppose its the base value itself
362 0         0 return $name;
363             }
364 0         0 my $resp = shift @{$responses};
  0         0  
365 0         0 my $req = shift @{$requests};
  0         0  
366 0 0       0 $self->_die($resp->{error}) if $resp->{error};
367             #print Dumper($req,$resp);
368 0         0 return $self->_extract_value($req,$resp);
369             }
370              
371             # Normalize value if a unit-of-measurement is given.
372              
373             # Units and how to convert from one level to the next
374             my @UNITS = ([ qw(ns us ms s m h d) ],[qw(B KB MB GB TB)]);
375             my %UNITS =
376             (
377             ns => 1,
378             us => 10**3,
379             ms => 10**3,
380             s => 10**3,
381             m => 60,
382             h => 60,
383             d => 24,
384              
385             B => 1,
386             KB => 2**10,
387             MB => 2**10,
388             GB => 2**10,
389             TB => 2**10
390             );
391              
392             sub _normalize_value {
393 13     13   12300 my $self = shift;
394 13         21 my $value = shift;
395 13   50     36 my $unit = shift || $self->unit || return ($value,undef);
396            
397 13         25 for my $units (@UNITS) {
398 17         18 for my $i (0 .. $#{$units}) {
  17         42  
399 72 100       148 next unless $units->[$i] eq $unit;
400 13         16 my $ret = $value;
401 13         15 my $u = $unit;
402 13 100       32 if (abs($ret) > 1) {
403             # Go up the scale ...
404 8 100       9 return ($value,$unit) if $i == $#{$units};
  8         23  
405 6         9 for my $j ($i+1 .. $#{$units}) {
  6         9  
406 12 100       35 if (abs($ret / $UNITS{$units->[$j]}) >= 1) {
407 6         11 $ret /= $UNITS{$units->[$j]};
408 6         9 $u = $units->[$j];
409             } else {
410 6         22 return ($ret,$u);
411             }
412             }
413             } else {
414             # Go down the scale ...
415 5 50       31 return ($value,$unit) if $i == 0;
416 5         12 for my $j (reverse(0 .. $i-1)) {
417 8 100       13 if ($ret < 1) {
418 5         25 $ret *= $UNITS{$units->[$j+1]};
419 5         10 $u = $units->[$j];
420             } else {
421 3         14 return ($ret,$u);
422             }
423             }
424            
425             }
426 2         8 return ($ret,$u);
427             }
428             }
429 0         0 die "Unknown unit '$unit' for value $value";
430             }
431              
432             sub _sanitize_value {
433 0     0   0 my ($self,$value) = @_;
434 0 0       0 if ($value =~ /\de/i) {
435 0         0 $value = sprintf("%f", $value);
436             }
437 0         0 return $value;
438             }
439              
440             sub _verify_response {
441 0     0   0 my ($self,$req,$resp) = @_;
442 0         0 my $np = $self->{np};
443 0 0       0 if ($resp->is_error) {
444 0         0 my $extra = "";
445 0 0       0 if ($np->opts->{verbose}) {
446 0         0 my $stacktrace = $resp->stacktrace;
447 0 0       0 $extra = ref($stacktrace) eq "ARRAY" ? join "\n",@$stacktrace : $stacktrace if $stacktrace;
    0          
448             }
449 0         0 $self->_die("Error: ".$resp->status." ".$resp->error_text.$extra);
450             }
451            
452 0 0 0     0 if (!$req->is_mbean_pattern && (ref($resp->value) && !$self->string) && !JSON::is_bool($resp->value)) {
      0        
      0        
453 0         0 $self->_die("Response value is a " . ref($resp->value) .
454             ", not a plain value. Did you forget a --path parameter ?". " Value: " .
455             Dumper($resp->value));
456             }
457             }
458              
459             sub _get_name {
460 1     1   2 my $self = shift;
461 1         3 my $args = { @_ };
462 1         3 my $name = $args->{name};
463 1 50       4 if (!$name) {
464 1 50       4 if ($self->name) {
465 1         15 $name = $self->name;
466             } else {
467             # Default name, tried to be generated from various parts
468 0 0       0 if ($self->alias) {
469 0 0       0 $name = "[".$self->alias.($self->path ? "," . $self->path : "") ."]";
470             } else {
471 0         0 my $val = $self->value;
472 0 0       0 if ($val) {
473 0         0 $name = "[" . $val . "]";
474             } else {
475 0   0     0 my $a_or_o = $self->attribute || $self->operation || "";
476 0 0       0 my $p = $self->path ? "," . $self->path : "";
477 0         0 $name = "[" . $self->mbean . "," . $a_or_o . $p . "]";
478             }
479             }
480             }
481             }
482 1 50       12 if ($args->{cleanup}) {
483             # Enable this when '=' gets forbidden
484 0         0 $name =~ s/=/#/g;
485             }
486             # Prepare label for usage with Monitoring::Plugin, which will blindly
487             # add quotes if a space is contained in the label.
488             # We are doing the escape of quotes ourself here
489 1         2 $name =~ s/'/''/g;
490 1         6 return $name;
491             }
492              
493             sub _prepare_read_args {
494 0     0   0 my $self = shift;
495 0         0 my $np = $self->{np};
496 0         0 my $jmx = shift;
497              
498 0 0       0 if ($self->alias) {
    0          
499 0         0 my @req_args = $jmx->resolve_alias($self->alias);
500 0 0       0 $self->_die("Cannot resolve attribute alias ",$self->alias()) unless @req_args > 0;
501 0 0       0 if ($self->path) {
502 0 0       0 @req_args == 2 ? $req_args[2] = $self->path : $req_args[2] .= "/" . $self->path;
503             }
504 0         0 return @req_args;
505             } elsif ($self->value) {
506 0         0 return $self->_split_attr_spec($self->value);
507             } else {
508 0         0 return ($self->mbean,$self->attribute,$self->path);
509             }
510             }
511              
512             sub _prepare_exec_args {
513 0     0   0 my $self = shift;
514 0         0 my $np = $self->{np};
515 0         0 my $jmx = shift;
516              
517             #print Dumper($self->{config});
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) ne "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   850 my $self = shift;
617 1         7 my $args = { @_ };
618             # Custom label has precedence
619 1 50       14 return $self->_format_label($self->label,$args) if $self->label;
620              
621 1         3 my $code = $args->{code};
622 1         3 my $mode = $args->{mode};
623 1 50 33     8 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     8 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       4 if ($mode ne "numeric") {
642 0         0 return $self->_format_label('%n : \'%v\' as expected',$args);
643             } else {
644 1         4 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   3 my ($args,$c) = @_;
653 1         2 my $val;
654 1 50       9 if ($c eq "v") {
655 1         3 $val = $args->{value};
656             } else {
657 0         0 $val = $args->{base};
658             }
659 1 50       9 return ($val =~ /\./ ? "%.2" : "%") . $c;
660             }
661              
662             sub _format_label {
663 1     1   2 my $self = shift;
664 1         2 my $label = shift;
665 1         2 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         9 my @parts = split /(\%[\w\.\-]*\w)/,$label;
678 1         3 my $ret = "";
679 1         2 foreach my $p (@parts) {
680 7 100       21 if ($p =~ /^(\%[\w\.\-]*)(\w)$/) {
681 3         7 my ($format,$what) = ($1,$2);
682 3 50 33     43 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     12 $ret .= sprintf $format . "s",($what eq "u" ? $args->{unit} : $args->{base_unit}) || "";
690 1         3 $ret =~ s/\s$//;
691             } elsif ($what eq "f") {
692 0         0 $ret .= sprintf $format . "f",$args->{value};
693             } elsif ($what eq "v") {
694 1         5 $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         11 $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         8 $ret .= $p;
712             }
713             }
714 1 50       5 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         5 return $ret;
720             }
721             }
722              
723             sub _format_value {
724 1     1   2 my $format = shift;
725 1         2 my $mode = shift;
726 1         2 my $value = shift;
727 1 50       3 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   2 my $val = shift;
735 1 50       15 $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   41 my $self = shift;
773 9         18 my $np = $self->{np};
774 9         15 my $name = $AUTOLOAD;
775 9         28 $name =~ s/.*://; # strip fully-qualified portion
776 9         16 $name =~ s/_/-/g;
777              
778 9 50       28 if ($CHECK_CONFIG_KEYS->{$name}) {
779 9 100       28 return $np->opts->{$name} if defined($np->opts->{$name});
780 3 50       23 if ($self->{config}) {
781 0         0 return $self->{config}->{$CHECK_CONFIG_KEYS->{$name}};
782             } else {
783 3         32 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     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;