File Coverage

blib/lib/JMX/Jmx4Perl/Product/BaseHandler.pm
Criterion Covered Total %
statement 48 219 21.9
branch 15 102 14.7
condition 8 53 15.0
subroutine 10 31 32.2
pod 15 17 88.2
total 96 422 22.7


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package JMX::Jmx4Perl::Product::BaseHandler;
4              
5 3     3   15 use strict;
  3         6  
  3         106  
6 3     3   16 use JMX::Jmx4Perl::Request;
  3         11  
  3         235  
7 3     3   32 use JMX::Jmx4Perl::Request;
  3         6  
  3         386  
8 3     3   2479 use JMX::Jmx4Perl::Alias;
  3         9  
  3         21  
9 3     3   16 use Carp qw(croak);
  3         4  
  3         149  
10 3     3   15 use Data::Dumper;
  3         5  
  3         7974  
11              
12             =head1 NAME
13              
14             JMX::Jmx4Perl::Product::BaseHandler - Base package for product specific handler
15              
16             =head1 DESCRIPTION
17              
18             This base class is used for specific L in order
19             to provide some common functionality. Extends this package if you want to hook
20             in your own product handler. Any module below
21             C will be automatically picked up by
22             L.
23              
24             =head1 METHODS
25              
26             =over
27              
28             =item $handler = JMX::Jmx4Perl::Product::MyHandler->new($jmx4perl);
29              
30             Constructor which requires a L object as single argument. If you
31             overwrite this method in a subclass, dont forget to call C, but
32             normally there is little need for overwritting new.
33              
34             =cut
35              
36              
37             sub new {
38 5     5 1 7 my $class = shift;
39 5   33     12 my $jmx4perl = shift || croak "No associated JMX::Jmx4Perl given";
40 5         11 my $self = {
41             jmx4perl => $jmx4perl
42             };
43 5   33     23 bless $self,(ref($class) || $class);
44 5         20 $self->{aliases} = $self->init_aliases();
45 5 50 33     89 if ($self->{aliases} && $self->{aliases}->{attributes}
      33        
46             && !$self->{aliases}->{attributes}->{SERVER_VERSION}) {
47             $self->{aliases}->{attributes}->{SERVER_VERSION} = sub {
48             # A little bit nasty, I know, but we have to rebuild
49             # the response since it is burried to deep into the
50             # version fetching mechanism. Still thinking about
51             # a cleaner solution .....
52 0     0   0 return new JMX::Jmx4Perl::Response
53             (
54             value => shift->version(),
55             status => 200,
56             timestamp => time
57             )
58 5         24 };
59             }
60 5         62 return $self;
61             }
62              
63             =item $id = $handler->id()
64              
65             Return the id of this handler, which must be unique among all handlers. This
66             method is abstract and must be overwritten by a subclass
67              
68             =cut
69              
70             sub id {
71 0     0 1 0 croak "Must be overwritten to return a name";
72             }
73              
74             =item $id = $handler->name()
75              
76             Return this handler's name. This method returns by default the id, but can
77             be overwritten by a subclass to provide something more descriptive.
78              
79             =cut
80              
81             sub name {
82 0     0 1 0 return shift->id;
83             }
84              
85             =item $vendor = $handler->vendor()
86              
87             Get the vendor for this product. If the handler support JSR 77 this is
88             extracted directly from the JSR 77 information. Otherwise, as handler is
89             recommended to detect the vendor on its own with a method C<_try_vendor>. Note, that he
90             shoudl query the server for this information and return C if it could
91             not be extracted from there. The default implementation of L
92             relies on the information fetched here.
93              
94             =cut
95              
96             sub vendor {
97 0     0 1 0 return shift->_version_or_vendor("vendor");
98             }
99              
100             =item $version = $handler->version()
101              
102             Get the version of the underlying application server or return C if the
103             version can not be determined. Please note, that this method can be only called
104             after autodetect() has been called since this call is normally used to fill in
105             that version number.
106              
107             =cut
108              
109             sub version {
110 0     0 1 0 return shift->_version_or_vendor("version");
111             }
112              
113             sub _version_or_vendor {
114 0     0   0 my $self = shift;
115 0         0 my $what = shift;
116 0         0 my $transform = shift;
117 0 0 0     0 die "Internal Error: '$what' must be either 'version' or 'vendor'"
118             if $what ne "version" && $what ne "vendor";
119            
120 0 0       0 if (!defined $self->{$what}) {
121 0 0       0 if ($self->can("_try_$what")) {
    0          
122 0         0 my $val;
123 0         0 eval "\$self->_try_$what";
124 0 0       0 die $@ if $@;
125             } elsif ($self->jsr77) {
126 0         0 $self->{$what} = $self->_server_info_from_jsr77("server" . (uc substr($what,0,1)) . substr($what,1));
127 0         0 $self->{"original_" . $what} = $self->{$what};
128 0 0 0     0 if ($transform && $self->{$what}) {
129 0 0       0 if (ref($transform) eq "CODE") {
    0          
130 0         0 $self->{$what} = &{$transform}($self->{$what});
  0         0  
131             } elsif (ref($transform) eq "Regexp") {
132 0 0       0 $self->{$what} = $1 if $self->{$what} =~ $transform;
133             }
134             }
135 0   0     0 $self->{$what} ||= "" # Set to empty string if not found
136             } else {
137 0         0 die "Internal error: Not a JSR77 Handler and no _try_$what method";
138             }
139             }
140 0         0 return $self->{$what};
141             }
142              
143             # Return the original version, which is not transformed. This contains
144             # often the application info as well. This returns a subroutine, suitable
145             # for usie in autodetect_pattern
146             sub original_version_sub {
147             return sub {
148 0     0   0 my $self = shift;
149 0         0 $self->version();
150 0         0 return $self->{"original_version"};
151             }
152 0     0 0 0 }
153              
154             =item $is_product = $handler->autodetect()
155              
156             Return true, if the appserver to which the given L (at
157             construction time) object is connected can be handled by this product
158             handler. If this module detects that it definitely can not handle this
159             application server, it returnd false. If an error occurs during autodectection,
160             this method should return C.
161              
162             =cut
163              
164             sub autodetect {
165 0     0 1 0 my $self = shift;
166 0         0 my ($what,$pattern) = $self->autodetect_pattern;
167 0 0       0 if ($what) {
168             #print "W: $what P: $pattern\n";
169 0         0 my $val;
170 0 0       0 if (ref($what) eq "CODE") {
171 0         0 $val = &{$what}($self);
  0         0  
172             } else {
173 0         0 eval "\$val = \$self->$what";
174 0 0       0 die $@ if $@;
175             }
176 0 0 0     0 return 1 if ($val && (!$pattern || ref($pattern) ne "Regexp"));
      0        
177 0 0 0     0 return $val =~ $pattern if ($val && $pattern);
178             }
179 0         0 return undef;
180             }
181              
182             =item ($what,$pattern) = $handler->autodetect_pattern()
183              
184             Method returning a pattern which is applied to the vendor or version
185             information provided by the L or L in order to detect,
186             whether this handler matches the server queried. This pattern is used in the
187             default implementation of C to check for a specific product. By
188             default, this method returns (C,C) which implies, that autodetect
189             for this handler returns false. Override this with the pattern matching the
190             specific product to detect.
191              
192             =cut
193              
194             sub autodetect_pattern {
195 0     0 1 0 return (undef,undef);
196             }
197              
198             =item $order = $handler->order()
199              
200             Return some hint for the ordering of product handlers in the autodetection
201             chain. This default implementation returns C, which implies no specific
202             ordering. If a subclass returns an negative integer it will be put in front of
203             the chain, if it returns a positive integer it will be put at the end of the
204             chain, in ascending order, respectively. E.g for the autodetection chain, the
205             ordering index of the included handlers looks like
206              
207             -10,-5,-3,-1,undef,undef,undef,undef,undef,2,3,10000
208              
209             The ordering index of the fallback handler (which always fire) is 1000, so it
210             doesn't make sense to return a higher index for a custom producthandler.
211              
212             =cut
213              
214             sub order {
215 6     6 1 29 return undef;
216             }
217              
218             =item $can_jsr77 = $handler->jsr77()
219              
220             Return true if the app server represented by this handler is an implementation
221             of JSR77, which provides a well defined way how to access deployed applications
222             and other stuff on a JEE Server. I.e. it defines how MBean representing this
223             information has to be named. This base class returns false, but this method can
224             be overwritten by a subclass.
225              
226             =cut
227              
228             sub jsr77 {
229 0     0 1 0 return undef;
230             }
231              
232             =item ($mbean,$attribute,$path) = $self->alias($alias)
233              
234             =item ($mbean,$operation) = $self->alias($alias)
235              
236             Return the mbean and attribute name for an registered attribute alias, for an
237             operation alias, this method returns the mbean and the operation name. A
238             subclass should call this parent method if it doesn't know about a specific
239             alias, since JVM MXBeans are aliased here.
240              
241             Returns undef if this product handler doesn't know about the provided alias.
242              
243             =cut
244              
245             sub alias {
246 5     5 1 7 my ($self,$alias_or_name) = @_;
247 5         7 my $alias;
248 5 100       29 if (UNIVERSAL::isa($alias_or_name,"JMX::Jmx4Perl::Alias::Object")) {
249 2         5 $alias = $alias_or_name;
250             } else {
251 3   33     14 $alias = JMX::Jmx4Perl::Alias->by_name($alias_or_name)
252             || croak "No alias $alias_or_name known";
253             }
254 5         19 my $resolved_ref = $self->resolve_alias($alias);
255             # It has been defined by the handler, but set to 0. So it doesn't
256             # support this particular alias
257 5 50 33     22 return undef if (defined($resolved_ref) && !$resolved_ref);
258             # If the handler doesn't define the ref (so it's undef),
259             # use the default
260 5   33     11 my $aliasref = $resolved_ref || $alias->default();
261             # If there is no default, then there is no support, too.
262 5 50       8 return undef unless defined($aliasref);
263              
264 5 100       14 return $aliasref if (ref($aliasref) eq "CODE"); # return coderefs directly
265 4 50       10 croak "Internal: $self doesn't resolve $alias to an arrayref" if ref($aliasref) ne "ARRAY";
266 4 100       9 if (ref($aliasref->[0]) eq "CODE") {
267             # Resolve dynamically if required
268 1         3 $aliasref = &{$aliasref->[0]}($self);
  1         4  
269 1 50       7 croak "Internal: $self doesn't resolve $alias to an arrayref" if ref($aliasref) ne "ARRAY";
270             }
271 4 50       28 return $aliasref ? @$aliasref : undef;
272             }
273              
274             =item $description = $self->info()
275              
276             Get a textual description of the product handler. By default, it prints
277             out the id, the version and well known properties known by the Java VM
278              
279             =cut
280              
281             sub info {
282 0     0 1 0 my $self = shift;
283 0         0 my $verbose = shift;
284              
285 0         0 my $ret = "";
286 0         0 $ret .= $self->server_info($verbose);
287 0         0 $ret .= "-" x 80 . "\n";
288 0         0 $ret .= $self->jvm_info($verbose);
289             }
290              
291              
292             # Examines internal alias hash in order to return handler specific aliases
293             # Can be overwritten if something more esoteric is required
294             sub resolve_alias {
295 5     5 0 9 my $self = shift;
296 5         5 my $alias = shift;
297 5 50       18 croak "Not an alias object " unless (UNIVERSAL::isa($alias,"JMX::Jmx4Perl::Alias::Object"));
298 5 100       18 my $aliases = $self->{aliases}->{$alias->{type} eq "attribute" ? "attributes" : "operations"};
299 5   33     26 return $aliases && $aliases->{$alias->{alias}};
300             }
301              
302              
303             =item my $aliases = $self->init_aliases()
304              
305             Method used during construction of a handler for obtaining a translation map of
306             aliases to the real values. Each specific handler can overwrite this method to
307             return is own resolving map. The returned map has two top level keys:
308             C and C. Below these keys are the maps for attribute
309             and operation aliases, respectively. These two maps have alias names as keys
310             (not the alias objects themselves) and a data structure for the getting to the
311             aliased values. This data structure can be written in three variants:
312              
313             =over
314              
315             =item *
316              
317             A arrayref having two or three string values for attributes describing the real
318             MBean's name, the attribute name and an optional path within the value. For
319             operations, it's an arrayref to an array with two elements: The MBean name and
320             the operation name.
321              
322             =item *
323              
324             A arrayref to an array with a I value which must be a coderef. This
325             subroutine is called with the handler as single argument and is expected to
326             return an arrayref in the form described above.
327              
328             =item *
329              
330             A coderef, which is executed when Cget_attribute()> or
331             Cexecute()> is called and which is supossed to do the complete
332             lookup. The first argument to the subroutine is the handler which can be used
333             to access the L object. The additional argument are either the
334             value to set (for Cset_attribute()> or the operation's
335             arguments for Cexecute()>. This is the most flexible way for a
336             handler to do anything it likes to do when an attribute value is requested or
337             an operation is about to be executed. You have to return a
338             L object.
339              
340             =back
341              
342             Example :
343              
344             sub init_aliases {
345             my $self = shift;
346             return {
347             attributes => {
348             SERVER_ADDRESS => [ "jboss.system:type=ServerInfo", "HostAddress"],
349             SERVER_VERSION => sub {
350             return shift->version();
351             },
352             SERVER_HOSTNAME => [ sub { return [ "jboss.system:type=ServerInfo", "HostName" ] } ]
353             },
354             operations => {
355             THREAD_DUMP => [ "jboss.system:type=ServerInfo", "listThreadDump"]
356             }
357             }
358             }
359              
360             Of course, you are free to overwrite C or
361             C on your own in order to do want you want it to do.
362              
363             This default implementation returns an empty hashref.
364              
365             =cut
366              
367             sub init_aliases {
368 0     0 1   my $self = shift;
369 0           return {};
370             }
371              
372              
373             =item $has_attribute = $handler->try_attribute($jmx4perl,$property,$object,$attribute,$path)
374              
375             Internal method which tries to request an attribute. If it could not be found,
376             it returns false.
377              
378             The first arguments C<$property> specifies an property of this object, which is
379             set with the value of the found attribute or C<0> if this attribute does not
380             exist.
381              
382             The server call is cached internally by examing C<$property>. So, never change
383             or set this property on this object manually.
384              
385             =cut
386              
387             sub try_attribute {
388 0     0 1   my ($self,$property,$object,$attribute,$path) = @_;
389            
390 0           my $jmx4perl = $self->{jmx4perl};
391              
392 0 0         if (defined($self->{$property})) {
393 0           return length($self->{$property});
394             }
395 0           my $request = JMX::Jmx4Perl::Request->new(READ,$object,$attribute,$path);
396 0           my $response = $jmx4perl->request($request);
397 0 0 0       if ($response->status == 404 || $response->status == 400) {
    0          
398 0           $self->{$property} = "";
399             } elsif ($response->is_ok) {
400 0           $self->{$property} = $response->value;
401             } else {
402 0           croak "Error : ",$response->error_text();
403             }
404 0           return length($self->{$property});
405             }
406              
407             =item $server_info = $handler->server_info()
408              
409             Get's a textual description of the server. By default, this includes the id and
410             the version, but can (and should) be overidden by a subclass to contain more
411             specific information
412              
413             =cut
414              
415             sub server_info {
416 0     0 1   my $self = shift;
417 0           my $jmx4perl = $self->{jmx4perl};
418 0           my $ret = "";
419 0           $ret .= sprintf("%-10.10s %s\n","Name:",$self->name);
420 0 0 0       $ret .= sprintf("%-10.10s %s\n","Vendor:",$self->vendor) if $self->vendor && $self->vendor ne $self->name;
421 0 0         $ret .= sprintf("%-10.10s %s\n","Version:",$self->version) if $self->version;
422 0           return $ret;
423             }
424              
425             =item $jvm_info = $handler->jvm_info()
426              
427             Get information which is based on well known MBeans which are available for
428             every Virtual machine. This is a textual representation of the information.
429              
430             =cut
431              
432              
433             sub jvm_info {
434 0     0 1   my $self = shift;
435 0           my $verbose = shift;
436 0           my $jmx4perl = $self->{jmx4perl};
437            
438 0           my @info = (
439             "Memory" => [
440             "mem" => [ "Heap-Memory used", MEMORY_HEAP_USED ],
441             "mem" => [ "Heap-Memory alloc", MEMORY_HEAP_COMITTED ],
442             "mem" => [ "Heap-Memory max", MEMORY_HEAP_MAX ],
443             "mem" => [ "NonHeap-Memory max", MEMORY_NONHEAP_MAX ],
444             ],
445             "Classes" => [
446             "nr" => [ "Classes loaded", CL_LOADED ],
447             "nr" => [ "Classes total", CL_TOTAL ]
448             ],
449             "Threads" => [
450             "nr" => [ "Threads current", THREAD_COUNT ],
451             "nr" => [ "Threads peak", THREAD_COUNT_PEAK ]
452             ],
453             "OS" => [
454             "str" => [ "CPU Arch", OS_INFO_ARCH ],
455             "str" => [ "CPU OS",OS_INFO_NAME,OS_INFO_VERSION],
456             "mem" => [ "Memory total",OS_MEMORY_PHYSICAL_FREE],
457             "mem" => [ "Memory free",OS_MEMORY_PHYSICAL_FREE],
458             "mem" => [ "Swap total",OS_MEMORY_SWAP_TOTAL],
459             "mem" => [ "Swap free",OS_MEMORY_SWAP_FREE],
460             "nr" => [ "FileDesc Open", OS_FILE_DESC_OPEN ],
461             "nr" => [ "FileDesc Max", OS_FILE_DESC_MAX ]
462             ],
463             "Runtime" => [
464             "str" => [ "Name", RUNTIME_NAME ],
465             "str" => [ "JVM", RUNTIME_VM_VERSION,RUNTIME_VM_NAME,RUNTIME_VM_VENDOR ],
466             "duration" => [ "Uptime", RUNTIME_UPTIME ],
467             "time" => [ "Starttime", RUNTIME_STARTTIME ]
468             ]
469             );
470 0           my $ret = "";
471              
472             # Collect all alias and create a map with values
473 0           my $info_map = $self->_fetch_info(\@info);
474             # Prepare output
475 0           while (@info) {
476 0           my $titel = shift @info;
477 0           my $e = shift @info;
478 0           my $val = "";
479 0           while (@$e) {
480 0           $self->_append_info($info_map,\$val,shift @$e,shift @$e);
481             }
482 0 0         if (length $val) {
483 0           $ret .= $titel . ":\n";
484 0           $ret .= $val;
485             }
486             }
487            
488 0 0         if ($verbose) {
489 0           my $args = "";
490 0           my $rt_args = $self->_get_attribute(RUNTIME_ARGUMENTS);
491 0 0         if ($rt_args) {
492 0           for my $arg (@{$rt_args}) {
  0            
493 0           $args .= $arg . " ";
494 0           my $i = 1;
495 0 0         if (length($args) > $i * 60) {
496 0           $args .= "\n" . (" " x 24);
497 0           $i++;
498             }
499             }
500 0           $ret .= sprintf(" %-20.20s %s\n","Arguments:",$args);
501             }
502 0           my $sys_props = $self->_get_attribute(RUNTIME_SYSTEM_PROPERTIES);
503 0 0         if ($sys_props) {
504 0           $ret .= "System Properties:\n";
505 0 0         if (ref($sys_props) eq "HASH") {
506 0           $sys_props = [ values %$sys_props ];
507             }
508 0           for my $prop (@{$sys_props}) {
  0            
509 0           $ret .= sprintf(" %-40.40s = %s\n",$prop->{key},$prop->{value});
510             }
511             }
512             }
513 0           return $ret;
514             }
515              
516             # Bulk fetch of alias information
517             # Return: Map with aliases as keys and response values as values
518             sub _fetch_info {
519 0     0     my $self = shift;
520 0           my $info = shift;
521 0           my $jmx4perl = $self->{jmx4perl};
522 0           my @reqs = ();
523 0           my @aliases = ();
524 0           my $info_map = {};
525 0           for (my $i=1; $i < @$info; $i += 2) {
526 0           my $attr_list = $info->[$i];
527 0           for (my $j=1;$j < @$attr_list;$j += 2) {
528 0           my $alias_list = $attr_list->[$j];
529 0           for (my $k=1;$k < @$alias_list;$k++) {
530 0           my $alias = $alias_list->[$k];
531 0           my @args = $jmx4perl->resolve_alias($alias);
532 0 0         next unless $args[0];
533 0           push @reqs,new JMX::Jmx4Perl::Request(READ,@args);
534 0           push @aliases,$alias;
535             }
536             }
537             }
538 0           my @resps = $jmx4perl->request(@reqs);
539             #print Dumper(\@resps);
540 0           foreach my $resp (@resps) {
541 0           my $alias = shift @aliases;
542 0 0         if ($resp->{status} == 200) {
543 0           $info_map->{$alias} = $resp->{value};
544             }
545             }
546 0           return $info_map;
547             }
548              
549             # Fetch version and vendor from jrs77
550             sub _server_info_from_jsr77 {
551 0     0     my $self = shift;
552 0           my $info = shift;
553 0           my $jmx = $self->{jmx4perl};
554              
555 0           my $servers = $jmx->search("*:j2eeType=J2EEServer,*");
556 0 0 0       return "" if (!$servers || !@$servers);
557            
558             # Take first server and lookup its version
559 0           return $jmx->get_attribute($servers->[0],$info);
560             }
561              
562              
563             sub _append_info {
564 0     0     my $self = shift;
565 0           my $info_map = shift;
566 0           my $r = shift;
567 0           my $type = shift;
568 0           my $content = shift;
569 0           my $label = shift @$content;
570 0           my $value = $info_map->{shift @$content};
571 0 0         return unless defined($value);
572 0 0 0       if ($type eq "mem") {
    0          
    0          
    0          
573 0           $value = int($value/(1024*1024)) . " MB";
574             } elsif ($type eq "str" && @$content) {
575 0           while (@$content) {
576 0           $value .= " " . $info_map->{shift @$content};
577             }
578             } elsif ($type eq "duration") {
579 0           $value = &_format_duration($value);
580             } elsif ($type eq "time") {
581 0           $value = scalar(localtime($value/1000));
582             }
583 0           $$r .= sprintf(" %-20.20s: %s\n",$label,$value);
584             }
585              
586             sub _get_attribute {
587 0     0     my $self = shift;
588            
589 0           my $jmx4perl = $self->{jmx4perl};
590 0           my @args = $jmx4perl->resolve_alias(shift);
591 0 0         return undef unless $args[0];
592 0           my $request = new JMX::Jmx4Perl::Request(READ,@args);
593 0           my $response = $jmx4perl->request($request);
594 0 0         return undef if $response->status == 404; # Ignore attributes not found
595 0 0         return $response->value if $response->is_ok;
596 0           die "Error fetching attribute ","@_",": ",$response->error_text;
597             }
598              
599             sub _format_duration {
600 0     0     my $millis = shift;
601 0           my $total = int($millis/1000);
602 0           my $days = int($total/(60*60*24));
603 0           $total -= $days * 60 * 60 * 24;
604 0           my $hours = int($total/(60*60));
605 0           $total -= $hours * 60 * 60;
606 0           my $minutes = int($total/60);
607 0           $total -= $minutes * 60;
608 0           my $seconds = $total;
609 0           my $ret = "";
610 0 0         $ret .= "$days d, " if $days;
611 0 0         $ret .= "$hours h, " if $hours;
612 0 0         $ret .= "$minutes m, " if $minutes;
613 0 0         $ret .= "$seconds s" if $seconds;
614 0           return $ret;
615             }
616              
617              
618              
619             =back
620              
621             =head1 LICENSE
622              
623             This file is part of jmx4perl.
624              
625             Jmx4perl is free software: you can redistribute it and/or modify
626             it under the terms of the GNU General Public License as published by
627             the Free Software Foundation, either version 2 of the License, or
628             (at your option) any later version.
629              
630             jmx4perl is distributed in the hope that it will be useful,
631             but WITHOUT ANY WARRANTY; without even the implied warranty of
632             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
633             GNU General Public License for more details.
634              
635             You should have received a copy of the GNU General Public License
636             along with jmx4perl. If not, see .
637              
638             A commercial license is available as well. Please contact roland@cpan.org for
639             further details.
640              
641             =head1 AUTHOR
642              
643             roland@cpan.org
644              
645             =cut
646              
647             1;