File Coverage

blib/lib/JMX/Jmx4Perl.pm
Criterion Covered Total %
statement 107 371 28.8
branch 35 192 18.2
condition 8 84 9.5
subroutine 18 43 41.8
pod 16 19 84.2
total 184 709 25.9


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             =head1 NAME
4              
5             JMX::Jmx4Perl - JMX access for Perl
6              
7             =head1 SYNOPSIS
8              
9             Simple:
10              
11             use strict;
12             use JMX::Jmx4Perl;
13             use JMX::Jmx4Perl::Alias; # Import MBean aliases
14              
15             print "Memory Used: ",
16             JMX::Jmx4Perl
17             ->new(url => "http://localhost:8080/j4p")
18             ->get_attribute(MEMORY_HEAP_USED);
19              
20             Advanced:
21              
22             use strict;
23             use JMX::Jmx4Perl;
24             use JMX::Jmx4Perl::Request; # Type constants are exported here
25            
26             my $jmx = new JMX::Jmx4Perl(url => "http://localhost:8080/j4p",
27             product => "jboss");
28             my $request = new JMX::Jmx4Perl::Request({type => READ,
29             mbean => "java.lang:type=Memory",
30             attribute => "HeapMemoryUsage",
31             path => "used"});
32             my $response = $jmx->request($request);
33             print "Memory used: ",$response->value(),"\n";
34              
35             # Get general server information
36             print "Server Info: ",$jmx->info();
37              
38             =head1 DESCRIPTION
39              
40             Jmx4Perl is here to connect the Java and Perl Enterprise world by providing
41             transparent access to the Java Management Extensions (JMX) from the perl side.
42              
43             It uses a traditional request-response paradigma for performing JMX operations
44             on a remote Java Virtual machine.
45              
46             There a various ways how JMX information can be transfered. Jmx4Perl is based
47             on a Jolokia I (www.jolokia.org), which needs to deployed on the target
48             platform. It plays the role of a proxy, which on one side communicates with the
49             MBeanServer within in the application server and transfers JMX related
50             information via HTTP and JSON to the client (i.e. this module). Please refer to
51             L for installation instructions for how to deploy the
52             Jolokia agent.
53              
54             An alternative and more 'java like' approach is the usage of JSR 160
55             connectors. However, the default connectors provided by the Java Virtual
56             Machine (JVM) since version 1.5 support only proprietary protocols which
57             require serialized Java objects to be exchanged. This implies that a JVM needs
58             to be started on the client side adding quite some overhead if used from within
59             Perl. If you absolutely require JSR 160 communication (e.g. because a agent can
60             not be deployed on the target for some reason), you can still use Jmx4Perl
61             operating with the so called I.
62              
63             For further discussion comparing both approaches, please refer to
64             L
65              
66             JMX itself knows about the following operations on so called I, which
67             are specific "managed beans" designed for JMX and providing access to
68             management functions:
69              
70             =over
71              
72             =item *
73              
74             Reading and writing of attributes of an MBean (like memory usage or connected
75             users)
76              
77             =item *
78              
79             Executing of exposed operations (like triggering a garbage collection)
80              
81             =item *
82              
83             Registering of notifications which are send from the application server to a
84             listener when a certain event happens.
85              
86             =back
87              
88             =head1 METHODS
89              
90             =over
91              
92             =cut
93              
94             package JMX::Jmx4Perl;
95              
96 3     3   22524 use Carp;
  3         5  
  3         301  
97 3     3   1914 use JMX::Jmx4Perl::Request;
  3         7  
  3         200  
98 3     3   1855 use JMX::Jmx4Perl::Config;
  3         35  
  3         115  
99 3     3   35 use strict;
  3         6  
  3         121  
100 3     3   16 use vars qw($VERSION $HANDLER_BASE_PACKAGE @PRODUCT_HANDLER_ORDERING);
  3         7  
  3         212  
101 3     3   17 use Data::Dumper;
  3         5  
  3         166  
102 3     3   2598 use Module::Find;
  3         4780  
  3         258  
103 3     3   1981 use JSON;
  3         24335  
  3         23  
104              
105             $VERSION = "1.11_2";
106              
107             my $REGISTRY = {
108             # Agent based
109             "agent" => "JMX::Jmx4Perl::Agent",
110             "JMX::Jmx4Perl::Agent" => "JMX::Jmx4Perl::Agent",
111             "JJAgent" => "JMX::Jmx4Perl::Agent",
112             };
113              
114             my %PRODUCT_HANDLER;
115              
116             sub _register_handlers {
117 4     4   12 my $handler_package = shift;
118 4         21 %PRODUCT_HANDLER = ();
119            
120 4         6 my @id2order = ();
121 4         22 for my $handler (findsubmod $handler_package) {
122 47 50       12871 next unless $handler;
123 47         65 my $handler_file = $handler;
124 47         187 $handler_file =~ s|::|/|g;
125 47         32927 require $handler_file.".pm";
126 47 100       369 next if $handler eq $handler_package."::BaseHandler";
127 44         2323 my $id = eval "${handler}::id()";
128 44 50       170 die "No id() method on $handler: $@" if $@;
129 44         126 $PRODUCT_HANDLER{lc $id} = $handler;
130 44         189 push @id2order, [ lc $id, $handler->order() ];
131             }
132             # Ordering Schema according to $handler->order():
133             # -10,-5,-3,0,undef,undef,undef,1,8,9,1000
134 4 100       21 my @high = map { $_->[0] } sort { $a->[1] <=> $b->[1] } grep { defined($_->[1]) && $_->[1] <= 0 } @id2order;
  4         18  
  0         0  
  44         182  
135 4         10 my @med = map { $_->[0] } grep { not defined($_->[1]) } @id2order;
  9         23  
  44         69  
136 4 100       21 my @low = map { $_->[0] } sort { $a->[1] <=> $b->[1] } grep { defined($_->[1]) && $_->[1] > 0 } @id2order;
  31         58  
  75         85  
  44         161  
137 4         13685 @PRODUCT_HANDLER_ORDERING = (@high,@med,@low);
138             }
139              
140             BEGIN {
141 3     3   1374 &_register_handlers("JMX::Jmx4Perl::Product");
142             }
143              
144              
145             =item $jmx = JMX::Jmx4Perl->new(mode => , ....)
146              
147             Create a new instance. The call is dispatched to an Jmx4Perl implementation by
148             selecting an appropriate mode. For now, the only mode supported is "agent",
149             which uses the L backend. Hence, the mode can be
150             submitted for now.
151              
152             Options can be given via key value pairs (or via a hash). Recognized options
153             are:
154              
155             =over
156              
157             =item server
158              
159             You can provide a server name which is looked up in a configuration file. The
160             configuration file's name can be given via C (see below) or, by
161             default, C<.j4p> in the users home directory is used.
162              
163             =item config_file
164              
165             Path to a configuration file to use
166              
167             =item config
168              
169             A L object which is used for
170             configuraton. Use this is you already read in the
171             configuration on your own.
172              
173             =item product
174              
175             If you provide a product id via the named parameter C you can given
176             B a hint which server you are using. By default, this module uses
177             autodetection to guess the kind of server you are talking to. You need to
178             provide this argument only if you use B's alias feature and if you
179             want to speed up things (autodetection can be quite slow since this requires
180             several JMX request to detect product specific MBean attributes).
181              
182             =item timeout
183              
184             Timeout in seconds for an HTTP request
185              
186             =item method
187              
188             Default HTTP method to use for requests which can be overridden for each
189             specific request
190              
191             =back
192              
193             Any other named parameters are interpreted by the backend, please
194             refer to its documentation for details (i.e. L)
195              
196             =cut
197              
198             sub new {
199 4     4 1 1516 my $class = shift;
200 4 50       25 my $cfg = ref($_[0]) eq "HASH" ? $_[0] : { @_ };
201              
202             # Merge in config from a configuration file if a server name is given
203 4 50       17 if ($cfg->{server}) {
204 0 0       0 my $config = $cfg->{config} ? $cfg->{config} : new JMX::Jmx4Perl::Config($cfg->{config_file});
205 0         0 my $server_cfg = $config->get_server_config($cfg->{server});
206 0 0       0 if (defined($server_cfg)) {
207 0         0 $cfg = { %$server_cfg, %$cfg };
208             }
209             }
210            
211 4   33     24 my $mode = delete $cfg->{mode} || autodiscover_mode();
212 4 100       14 my $product = $cfg->{product} ? lc delete $cfg->{product} : undef;
213              
214 4   33     19 $class = $REGISTRY->{$mode} || croak "Unknown runtime mode " . $mode;
215 4 50 66     20 if ($product && !$PRODUCT_HANDLER{lc $product}) {
216 0         0 die "No handler for product '$product'. Known Handlers are [".(join ", ",keys %PRODUCT_HANDLER)."]";
217             }
218              
219 4         221 eval "require $class";
220 4 50       22 croak "Cannot load $class: $@" if $@;
221              
222 4         19 my $self = {
223             cfg => $cfg,
224             product => $product
225             };
226 4   33     28 bless $self,(ref($class) || $class);
227 4         16 $self->init();
228 4         16 return $self;
229             }
230              
231             # ==========================================================================
232              
233             =item $value => $jmx->get_attribute(...)
234              
235             $value = $jmx->get_attribute($mbean,$attribute,$path)
236             $value = $jmx->get_attribute($alias)
237             $value = $jmx->get_attribute(ALIAS) # Literal alias as defined in
238             # JMX::Jmx4Perl::Alias
239             $value = $jmx->get_attribute({ domain => ,
240             properties => { => value },
241             attribute => ,
242             path => })
243             $value = $jmx->get_attribute({ alias => ,
244             path =>
245              
246             Read a JMX attribute. In the first form, you provide the MBean name, the
247             attribute name and an optional path as positional arguments. The second
248             variant uses named parameters from a hashref.
249              
250             The Mbean name can be specified with the canonical name (key C), or with
251             a domain name (key C) and one or more properties (key C or
252             C) which contain key-value pairs in a Hashref. For more about naming of
253             MBeans please refer to
254             L for
255             more information about JMX naming.
256              
257             Alternatively, you can provide an alias, which gets resolved to its real name
258             by so called I. Several product handlers are provided out of
259             the box. If you have specified a C id during construction of this
260             object, the associated handler is selected. Otherwise, autodetection is used to
261             guess the product. Note, that autodetection is potentially slow since it
262             involves several JMX calls to the server. If you call with a single, scalar
263             value, this argument is taken as alias (without any path). If you want to use
264             aliases together with a path, you need to use the second form with a hash ref
265             for providing the (named) arguments.
266              
267             Additionally you can use a pattern and/or an array ref for attributes to
268             combine multiple reads into a single request. With an array ref as attribute
269             argument, all the given attributes are queried. If C<$attribute> is C
270             all attributes on the MBean are queried.
271              
272             If you provide a pattern as described for the L<"/search"> method, a search
273             will be performed on the server side, an for all MBeans found which carry the
274             given attribute(s), their value will be returned. Attributes which doesn't
275             apply to an MBean are ignored.
276              
277             Note, that the C feature is not available when using MBean patterns or
278             multiple values.
279              
280             Depending on the arguments, this method return value has a different format:
281              
282             =over 4
283              
284             =item Single MBean, single attribute
285              
286             The return value is the result of the serverside read operation. It will throw
287             an exception (die), if an error occurs on the server side, e.g. when the name
288             couldn't be found.
289              
290             Example:
291              
292             $val = $jmx->get_attribute("java.lang:type=Memory","HeapMemoryUsage");
293             print Dumper($val);
294              
295             {
296             committed => 174530560,
297             init => 134217728,
298             max => "1580007424",
299             used => 35029320
300             }
301              
302             =item Single MBean, multiple attributes
303              
304             In this case, this method returns a map with the attribute name as keys and the
305             attribute values as map values. It will die if not a single attribute could be
306             fetched, otherwise unknown attributes are ignored.
307              
308             $val = $jmx->get_attribute(
309             "java.lang:type=Memory",
310             ["HeapMemoryUsage","NonHeapMemoryUsage"]
311             );
312             print Dumper($val);
313              
314             {
315             HeapMemoryUsage => {
316             committed => 174530560,
317             init => 134217728,
318             max => "1580007424",
319             used => 37444832
320             },
321             NonHeapMemoryUsage => {
322             committed => 87552000,
323             init => 24317952,
324             max => 218103808,
325             used => 50510976
326             }
327             }
328              
329             =item MBean pattern, one or more attributes
330              
331             $val = $jmx->get_attribute(
332             "java.lang:type=*",
333             ["HeapMemoryUsage","NonHeapMemoryUsage"]
334             );
335             print Dumper($val);
336              
337             {
338             "java.lang:type=Memory" => {
339             HeapMemoryUsage => {
340             committed => 174530560,
341             init => 134217728,
342             max => "1580007424",
343             used => 38868584
344             },
345             NonHeapMemoryUsage => {
346             committed => 87552000,
347             init => 24317952,
348             max => 218103808,
349             used => 50514304
350             }
351             }
352             }
353              
354             The return value is a map with the matching MBean names as keys and as value
355             another map, with attribute names keys and attribute value values. If not a
356             singel MBean matches or not a single attribute can be found on the matching
357             MBeans this method dies. This format is the same whether you are using a single
358             attribute or an array ref of attribute names.
359              
360             =back
361              
362             Please don't overuse pattern matching (i.e. don't use patterns like "*:*"
363             except you really want to) since this could easily blow up your Java
364             application. The return value is generated completely in memory. E.g if you
365             want to retrieve all attributes for Weblogic with
366              
367             $jmx->get_attribute("*:*",undef);
368              
369             you will load more than 200 MB in to the Heap. Probably not something you
370             want to do. So please be nice to your appserver and use a more restrictive
371             pattern.
372              
373             =cut
374              
375             sub get_attribute {
376 0     0 1 0 my $self = shift;
377 0         0 my ($object,$attribute,$path) = $self->_extract_get_set_parameters(with_value => 0,params => [@_]);
378 0 0       0 croak "No object name provided" unless $object;
379              
380 0         0 my $response;
381 0 0       0 if (ref($object) eq "CODE") {
382 0         0 $response = $self->delegate_to_handler($object);
383             } else {
384             #croak "No attribute provided for object $object" unless $attribute;
385 0         0 my $request = JMX::Jmx4Perl::Request->new(READ,$object,$attribute,$path);
386 0         0 $response = $self->request($request);
387             # print Dumper($response);
388             }
389 0 0       0 if ($response->is_error) {
390 0 0       0 my $a = ref($attribute) eq "ARRAY" ? "[" . join(",",@$attribute) . "]" : $attribute;
391 0 0       0 my $o = "(".$object.",".$a.($path ? "," . $path : "").")";
392 0 0       0 croak "The attribute $o is not registered on the server side"
393             if $response->status == 404;
394 0         0 croak "Error requesting $o: ",$response->error_text;
395             }
396 0         0 return $response->value;
397             }
398              
399             =item $resp = $jmx->set_attribute(...)
400              
401             $new_value = $jmx->set_attribute($mbean,$attribute,$value,$path)
402             $new_value = $jmx->set_attribute($alias,$value)
403             $new_value = $jmx->set_attribute(ALIAS,$value) # Literal alias as defined in
404             # JMX::Jmx4Perl::Alias
405             $new_value = $jmx->set_attribute({ domain => ,
406             properties => { => value },
407             attribute => ,
408             value => ,
409             path => })
410             $new_value = $jmx->set_attribute({ alias => ,
411             value => ,
412             path =>
413              
414             Method for writing an attribute. It has the same signature as L
415             except that it takes an additional parameter C for setting the value. It
416             returns the old value of the attribute (or the object pointed to by an inner
417             path).
418              
419             As for C you can use a path to specify an inner part of a more
420             complex data structure. The value is tried to set on the inner object which is
421             pointed to by the given path.
422              
423             Please note that only basic data types can be set this way. I.e you can set
424             only values of the following types
425              
426             =over
427              
428             =item C
429              
430             =item C
431              
432             =item C
433              
434             =back
435              
436             =cut
437              
438             sub set_attribute {
439 0     0 1 0 my $self = shift;
440              
441 0         0 my ($object,$attribute,$path,$value) =
442             $self->_extract_get_set_parameters(with_value => 1,params => [@_]);
443 0 0       0 croak "No object name provided" unless $object;
444 0         0 my $response;
445 0 0       0 if (ref($object) eq "CODE") {
446 0         0 $response = $self->delegate_to_handler($object,$value);
447             } else {
448 0 0       0 croak "No attribute provided for object $object" unless $attribute;
449 0 0       0 croak "No value to set provided for object $object and attribute $attribute" unless defined($value);
450 0         0 my $request = JMX::Jmx4Perl::Request->new(WRITE,$object,$attribute,$value,$path);
451 0         0 $response = $self->request($request);
452             }
453 0 0       0 if ($response->status == 404) {
454 0         0 return undef;
455             }
456 0         0 return $response->value;
457             }
458              
459             =item $info = $jmx->info($verbose)
460              
461             Get a textual description of the server as returned by a product specific
462             handler (see L). It uses the
463             autodetection facility if no product is given explicitely during construction.
464              
465             If C<$verbose> is true, print even more information
466              
467             =cut
468              
469             sub info {
470 0     0 1 0 my $self = shift;
471 0         0 my $verbose = shift;
472 0   0     0 my $handler = $self->{product_handler} || $self->_create_handler();
473 0         0 return $handler->info($verbose);
474             }
475              
476              
477             =item $mbean_list = $jmx->search($mbean_pattern)
478              
479             Search for MBean based on a pattern and return a reference to the list of found
480             MBeans names (as string). If no MBean can be found, C is returned. For
481             example,
482              
483             $jmx->search("*:j2eeType=J2EEServer,*")
484              
485             searches all MBeans whose name are matching this pattern, which are according
486             to JSR77 all application servers in all available domains.
487              
488             =cut
489              
490             sub search {
491 0     0 1 0 my $self = shift;
492 0   0     0 my $pattern = shift || croak "No pattern provided";
493            
494 0         0 my $request = new JMX::Jmx4Perl::Request(SEARCH,$pattern);
495 0         0 my $response = $self->request($request);
496              
497             # An error of 404 was the behaviour of Jolokia < 0.90,
498             # for > 0.90 an empty list was returned
499 0 0       0 return undef if $response->status == 404;
500 0 0       0 if ($response->is_error) {
501 0         0 die "Error searching for $pattern: ",$response->error_text;
502             }
503 0         0 my $val = $response->value;
504 0 0 0     0 return ref($val) eq "ARRAY" && @$val ? $val : undef;
505             }
506              
507             =item $ret = $jmx->execute(...)
508              
509             $ret = $jmx->execute($mbean,$operation,$arg1,$arg2,...)
510             $ret = $jmx->execute(ALIAS,$arg1,$arg2,...)
511              
512             $value = $jmx->execute({ domain => ,
513             properties => { => value },
514             operation => ,
515             arguments => [ , , ... ] })
516             $value = $jmx->execute({ alias => ,
517             arguments => [ , .... ]})
518              
519             Execute a JMX operation with the given arguments. If used in the second form,
520             with an alias as first argument, it is recommended to use the constant as
521             exported by L, otherwise it is guessed, whether the first
522             string value is an alias or a MBean name. To be sure, use the variant with an
523             hashref as argument.
524              
525             If you are calling an overloaded JMX operation (i.e. operations with the same
526             name but a different argument signature), the operation name must include the
527             signature as well. This is be done by adding the parameter types comma
528             separated within parentheses:
529              
530             ...
531             operation => "overloadedMethod(java.lang.String,int)"
532             ...
533              
534             This method will croak, if something fails during execution of this
535             operation or when the MBean/Operation combination could not be found.
536              
537             The return value of this method is the return value of the JMX operation.
538              
539             =cut
540              
541             sub execute {
542 0     0 1 0 my $self = shift;
543              
544 0         0 my @args = @_;
545 0         0 my ($mbean,$operation,$op_args) = $self->_extract_execute_parameters(@_);
546 0         0 my $response;
547 0 0       0 if (ref($mbean) eq "CODE") {
548 0         0 $response = $self->delegate_to_handler($mbean,@{$op_args});
  0         0  
549             } else {
550 0         0 my $request = new JMX::Jmx4Perl::Request(EXEC,$mbean,$operation,@{$op_args});
  0         0  
551 0         0 $response = $self->request($request);
552             }
553 0 0       0 if ($response->is_error) {
554 0 0       0 croak "No MBean ".$mbean." with operation ".$operation.
    0          
555             (@$op_args ? " (Args: [".join(",",@$op_args)."]" : "").") found on the server side"
556             if $response->status == 404;
557 0         0 croak "Error executing operation $operation on MBean $mbean: ",$response->error_text;
558             }
559 0         0 return $response->value;
560             }
561              
562              
563             =item $resp = $jmx->version()
564              
565             This method return the version of the agent as well as the j4p protocol
566             version. The agent's version is a regular program version and corresponds to
567             jmx4perl's version from which the agent has been taken. The protocol version
568             is an integer number which indicates the version of the protocol specification.
569              
570             The return value is a hash with the keys C and C
571              
572             =cut
573              
574             sub version {
575 0     0 1 0 my $self = shift;
576            
577 0         0 my $request = new JMX::Jmx4Perl::Request(AGENT_VERSION);
578 0         0 my $response = $self->request($request);
579              
580 0 0       0 if ($response->is_error) {
581 0         0 die "Error getting the agent's version: ",$response->error_text;
582             }
583              
584 0         0 return $response->value;
585             }
586              
587             =item $resp = $jmx->request($request)
588              
589             Send a request to the underlying agent and return the response. This is an
590             abstract method which needs to be overwritten by a subclass. The argument must
591             be of type L and it returns an object of type
592             L.
593              
594             =cut
595              
596             sub request {
597 0     0 1 0 croak "Internal: Must be overwritten by a subclass";
598             }
599              
600             =item $agents = JMX::Jmx4Perl->discover_agents($timeout)
601              
602             Discover agents by sending a multicast request on which Jolokia agents are
603             listening. The optional C<$timeout> can be used to tune how long to wait for
604             discovery answers (in seconds). By default 1 seconds is waited. This functionality
605             requires L to be installed.
606              
607             This methods returns an array ref, which looks like
608              
609             [
610             {
611             'version' => '1.2.0-SNAPSHOT',
612             'server_version' => '7.0.50',
613             'server_product' => 'tomcat',
614             'secured' => 0,
615             'url' => 'http://10.9.11.2:8778/jolokia/',
616             'server_vendor' => 'Apache',
617             'confidence' => 100,
618             'type' => 'response'
619             }
620             ]
621              
622             Please refer to Jolokia's reference documentation for the meaning of the keys.
623             The most important part it C which points to the agent's URL which can
624             be used to construct a new L object.
625              
626             =cut
627              
628              
629             sub discover_agents {
630 0     0 1 0 my $self = shift;
631 0         0 my $timeout = shift | 1;
632              
633 0         0 my $s;
634 0         0 eval {
635 0         0 $s = IO::Socket::Multicast->new();
636             };
637 0 0       0 if ($@) {
638 0         0 eval {
639 0         0 require "IO/Socket/Multicast.pm";
640 0         0 $s = IO::Socket::Multicast->new();
641             };
642 0 0       0 if ($@) {
643 0         0 die "No IO::Socket::Multicast installed\n";
644             }
645             }
646              
647 0         0 $s->mcast_send('{"type" : "query"}',"239.192.48.84:24884");
648            
649 0         0 my @result = ();
650 0         0 my $data;
651             LOOP:
652 0         0 while (1) {
653 0         0 eval {
654 0     0   0 local $SIG{ALRM} = sub { die "timeout\n" }; # NB: \n required
  0         0  
655 0         0 alarm $timeout;
656 0         0 $s->recv($data,8192);
657 0         0 push @result,from_json($data, {utf8 => 1} );
658 0         0 alarm 0;
659             };
660 0 0       0 if ($@) {
661 0 0       0 die unless $@ eq "timeout\n"; # propagate unexpected errors
662             # timed out
663 0         0 last LOOP;
664             }
665             }
666 0         0 return \@result;
667             }
668              
669             # ===========================================================================
670             # Alias handling
671              
672             =item ($object,$attribute,$path) = $self->resolve_alias($alias)
673              
674             Resolve an alias for an attibute or operation. This is done by querying registered
675             product handlers for resolving an alias. This method will croak if a handler
676             could be found but not such alias is known by C.
677              
678             If the C was not set during construction, the first call to this
679             method will try to autodetect the server. If it cannot determine the proper
680             server it will throw an exception.
681              
682             For an attribute, this method returns the object, attribute, path triple which
683             can be used for requesting the server or C if the handler can not
684             handle this alias.
685              
686             For an operation, the MBean, method name and the (optional) path, which should be
687             applied to the return value, is returned or C if the handler cannot
688             handle this alias.
689              
690             A handler can decide to handle the fetching of the alias value directly. In
691             this case, this metod returns the code reference which needs to be executed
692             with the handler as argument (see "delegate_to_handler") below.
693              
694             =cut
695              
696             sub resolve_alias {
697 5     5 1 314 my $self = shift;
698 5   33     15 my $alias = shift || croak "No alias provided";
699              
700 5   66     23 my $handler = $self->{product_handler} || $self->_create_handler();
701 5         25 return $handler->alias($alias);
702             }
703              
704             =item $do_support = $self->supports_alias($alias)
705              
706             Test for checking whether a handler supports a certain alias.
707              
708             =cut
709              
710             sub supports_alias {
711 0     0 1 0 my ($object) = shift->resolve_alias(shift);
712 0 0       0 return $object ? 1 : 0;
713             }
714              
715             =item $response = $self->delegate_to_handler($coderef,@args)
716              
717             Execute a subroutine with the current handler as argument and returns the
718             return value of this subroutine. This method is used in conjunction with
719             C to allow handler a more sophisticated way to access the
720             MBeanServer. The method specified by C<$coderef> must return a
721             L as answer.
722              
723             The subroutine is supposed to handle reading and writing of attributes and
724             execution of operations. Optional additional parameters are given to the subref
725             as additional arguments.
726              
727             =cut
728              
729             sub delegate_to_handler {
730 0     0 1 0 my $self = shift;
731 0         0 my $code = shift;
732 0   0     0 my $handler = $self->{product_handler} || $self->_create_handler();
733 0         0 return &{$code}($handler,@_);
  0         0  
734             }
735              
736             =item $product = $self->product()
737              
738             For supported application servers, this methods returns product handler
739             which is an object of type L.
740              
741             This product is either detected automatically or provided during
742             construction time.
743              
744             The most interesting methods on this object are C, C and
745             C
746              
747             =cut
748              
749             sub product {
750 0     0 1 0 my $self = shift;
751 0   0     0 my $handler = $self->{product_handler} || $self->_create_handler();
752 0         0 return $handler;
753             }
754              
755             =item $value = $jmx->list($path)
756              
757             Get all MBeans as registered at the specified server. A C<$path> can be
758             specified in order to fetchy only a subset of the information. When no path is
759             given, the returned value has the following format
760              
761             $value = {
762             =>
763             {
764             =>
765             {
766             "attr" =>
767             {
768             =>
769             {
770             desc =>
771             type => ,
772             rw => true/false
773             },
774             ....
775             },
776             "op" =>
777             {
778             =>
779             {
780             desc =>
781             ret =>
782             args =>
783             [
784             {
785             desc => ,
786             name => ,
787             type =>
788             },
789             ....
790             ]
791             },
792             ....
793             },
794             ....
795             }
796             ....
797             };
798              
799             A complete path has the format C<"EdomainE/Eproperty
800             listE/("attribute"|"operation")/EindexE">
801             (e.g. C). A path can be
802             provided partially, in which case the remaining map/array is returned. See also
803             L for a more detailed discussion of inner
804             paths.
805              
806             This method throws an exception if an error occurs.
807              
808             =cut
809              
810             sub list {
811 0     0 1 0 my $self = shift;
812 0         0 my $path = shift;
813              
814 0         0 my $request = JMX::Jmx4Perl::Request->new(LIST,$path);
815 0         0 my $response = $self->request($request);
816 0 0       0 if ($response->is_error) {
817 0         0 my $txt = "Error while listing attributes: " . $response->error_text . "\n" .
818             "Status: " . $response->status . "\n";
819             #($response->stacktrace ? "\n" . $response->stacktrace . "\n" : "\n");
820 0         0 die $txt;
821             }
822 0         0 return $response->value;
823             }
824              
825              
826             =item ($domain,$attributes) = $jmx->parse_name($name)
827              
828             Parse an object name into its domain and attribute part. If successful,
829             C<$domain> contains the domain part of the objectname, and C<$attribtutes> is a
830             hahsref to the attributes of the name with the attribute names as keys and the
831             attribute's values as values. This method returns C when the name could
832             not be parsed. Result of a C operation can be savely feed into this
833             method to get to the subparts of the name. JMX quoting is taken into account
834             properly, too.
835              
836             Example:
837              
838             my ($domain,$attrs) =
839             $jmx->parse_name("java.lang:name=Code Cache,type=MemoryPool");
840             print $domain,"\n",Dumper($attrs);
841              
842             java.lang
843             {
844             name => "Code Cache",
845             type => "MemoryPool"
846             }
847              
848             =cut
849              
850             sub parse_name {
851 8     8 1 5506 my $self = shift;
852 8         11 my $name = shift;
853 8         10 my $escaped = shift;
854              
855 8 100       23 return undef unless $name =~ /:/;
856 7         21 my ($domain,$rest) = split(/:/,$name,2);
857 7         19 my $attrs = {};
858 7         38 while ($rest =~ s/([^=]+)\s*=\s*//) {
859             #print "R: $rest\n";
860 11         24 my $key = $1;
861 11         11 my $value = undef;
862 11 100       25 if ($rest =~ /^"/) {
863 4         21 $rest =~ s/("((\\"|[^"])+)")(\s*,\s*|$)//;
864 4 50       15 $value = $escaped ? $1 : $2;
865             # Unescape escaped chars
866 4 50       18 $value =~ s/\\([:",=*?])/$1/g unless $escaped;
867             } else {
868 7 100       26 if ($rest =~ s/([^,]+)(\s*,\s*|$)//) {
869 6         10 $value = $1;
870             }
871             }
872 11 100       25 return undef unless defined($value);
873 10         41 $attrs->{$key} = $value;
874             #print "K: $key V: $value\n";
875             }
876             # If there is something left, we were not successful
877             # in parsing the name
878 6 100       14 return undef if $rest;
879 5         15 return ($domain,$attrs);
880             }
881              
882              
883             =item $formatted_text = $jmx->formatted_list($path)
884              
885             =item $formatted_text = $jmx->formatted_list($resp)
886              
887             Get the a formatted string representing the MBeans as returnded by C.
888             C<$path> is the optional inner path for selecting only a subset of all mbean.
889             See C for more details. If called with a L
890             object, the list and the optional path will be taken from the provided response
891             object and not fetched again from the server.
892              
893             =cut
894              
895             sub formatted_list {
896 0     0 1 0 my $self = shift;
897 0         0 my $path_or_resp = shift;
898 0         0 my $path;
899             my $list;
900            
901 0 0 0     0 if ($path_or_resp && UNIVERSAL::isa($path_or_resp,"JMX::Jmx4Perl::Response")) {
902 0         0 $path = $path_or_resp->request->get("path");
903 0         0 $list = $path_or_resp->value;
904             } else {
905 0         0 $path = $path_or_resp;
906 0         0 $list = $self->list($path);
907             }
908 0         0 my @path = ();
909 0 0       0 @path = split m|/|,$path if $path;
910             #print Dumper(\@path);
911 0 0       0 croak "A path can be used only for a domain name or MBean name" if @path > 2;
912 0         0 my $intent = "";
913 0         0 my $ret = &_format_map("",$list,\@path,0);
914             }
915              
916              
917             # ===============================================================================================
918              
919             # Helper method for extracting parameters for the set/get methods.
920             sub _extract_get_set_parameters {
921 0     0   0 my $self = shift;
922 0         0 my %args = @_;
923 0         0 my $p = $args{params};
924 0         0 my $f = $p->[0];
925 0         0 my $with_value = $args{with_value};
926 0         0 my ($object,$attribute,$path,$value);
927 0 0       0 if (ref($f) eq "HASH") {
928 0         0 $value = $f->{value};
929 0 0       0 if ($f->{alias}) {
930 0         0 my $alias_path;
931 0         0 ($object,$attribute,$alias_path) =
932             $self->resolve_alias($f->{alias});
933 0 0       0 if (ref($object) eq "CODE") {
934             # Let the handler do it
935 0 0       0 return ($object,undef,undef,$args{with_value} ? $value : undef);
936             }
937 0 0       0 croak "No alias ",$f->{alias}," defined for handler ",$self->product->name unless $object;
938 0 0       0 if ($alias_path) {
939 0 0       0 $path = $f->{path} ? $f->{path} . "/" . $alias_path : $alias_path;
940             } else {
941 0         0 $path = $f->{path};
942             }
943             } else {
944 0   0     0 $object = $f->{mbean} || $self->_glue_mbean_name($f) ||
945             croak "No MBean name or domain + properties given";
946 0         0 $attribute = $f->{attribute};
947 0         0 $path = $f->{path};
948             }
949             } else {
950 0 0 0     0 if ( (@{$p} == 1 && !$args{with_value}) ||
  0   0     0  
  0   0     0  
      0        
951             (@{$p} == 2 && $args{with_value}) || $self->_is_alias($p->[0])) {
952             # A single argument can only be used as an alias
953 0         0 ($object,$attribute,$path) =
954             $self->resolve_alias($f);
955 0         0 $value = $_[1];
956 0 0       0 if (ref($object) eq "CODE") {
957             # Let the handler do it
958 0 0       0 return ($object,undef,undef,$args{with_value} ? $value : undef);
959             }
960 0 0       0 croak "No alias ",$f," defined for handler ",$self->product->name unless $object;
961             } else {
962 0 0       0 if ($args{with_value}) {
963 0         0 ($object,$attribute,$value,$path) = @{$p};
  0         0  
964             } else {
965 0         0 ($object,$attribute,$path) = @{$p};
  0         0  
966             }
967             }
968             }
969 0         0 return ($object,$attribute,$path,$value);
970             }
971              
972             sub _extract_execute_parameters {
973 0     0   0 my $self = shift;
974 0         0 my @args = @_;
975 0         0 my ($mbean,$operation,$op_args);
976 0 0       0 if (ref($args[0] eq "JMX::Jmx4Perl::Request")) {
    0          
977 0         0 die 'Use $j4p->request(), not $j4p->execute() for executing a JMX::Jmx4Perl::Request',"\n";
978             } elsif (ref($args[0]) eq "HASH") {
979 0         0 my $args = $args[0];
980 0 0       0 if ($args->{alias}) {
981 0         0 ($mbean,$operation) = $self->resolve_alias($args->{alias});
982 0 0       0 if (ref($mbean) eq "CODE") {
983             # Alias handles this completely on its own
984 0   0     0 return ($mbean,undef,$args->{arguments} || $args->{args});
985             }
986 0 0       0 croak "No alias ",$args->{alias}," defined for handler ",$self->product->name unless $mbean;
987             } else {
988 0   0     0 $mbean = $args->{mbean} || $self->_glue_mbean_name($args) ||
989             croak "No MBean name or domain + properties given";
990 0   0     0 $operation = $args->{operation} || croak "No operation given";
991             }
992 0   0     0 $op_args = $args->{arguments} || $args->{args};
993             } else {
994 0 0       0 if ($self->_is_alias($args[0])) {
995 0         0 ($mbean,$operation) = $self->resolve_alias($args[0]);
996 0         0 shift @args;
997 0 0       0 if (ref($mbean) eq "CODE") {
998             # Alias handles this completely on its own
999 0         0 return ($mbean,undef,[ @args ]);
1000             }
1001 0 0       0 croak "No alias ",$args[0]," defined for handler ",$self->product->name unless $mbean;
1002 0         0 $op_args = [ @args ];
1003             } else {
1004 0         0 $mbean = shift @args;
1005 0         0 $operation = shift @args;
1006 0         0 $op_args = [ @args ];
1007             }
1008             }
1009 0         0 return ($mbean,$operation,$op_args);
1010             }
1011              
1012             # Check whether the argument is possibly an alias
1013             sub _is_alias {
1014 0     0   0 my $self = shift;
1015 0         0 my $alias = shift;
1016 0 0       0 if (UNIVERSAL::isa($alias,"JMX::Jmx4Perl::Alias::Object")) {
    0          
1017 0         0 return 1;
1018             } elsif (JMX::Jmx4Perl::Alias->by_name($alias)) {
1019 0         0 return 1;
1020             } else {
1021 0         0 return 0;
1022             }
1023             }
1024              
1025             sub _glue_mbean_name {
1026 0     0   0 my $self = shift;
1027 0         0 my $f = shift;
1028 0         0 my $object = undef;
1029 0 0 0     0 if ($f->{domain} && ($f->{properties} || $f->{props})) {
      0        
1030 0         0 $object = $f->{domain} . ":";
1031 0   0     0 my $href = $f->{properties} || $f->{props};
1032 0 0       0 croak "'properties' is not a hashref" unless ref($href);
1033 0         0 for my $k (keys %{$href}) {
  0         0  
1034 0         0 $object .= $k . "=" . $href->{$k};
1035             }
1036             }
1037 0         0 return $object;
1038             }
1039              
1040             sub _create_handler {
1041 3     3   6 my $self = shift;
1042 3 100       19 if (!$self->{product}) {
1043 2         9 ($self->{product},$self->{product_handler}) = $self->_autodetect_product();
1044             }
1045             # Create product handler if not created during autodetectiong (e.g. if the
1046             # product has been set explicitely)
1047 3 100       22 $self->{product_handler} = $self->_new_handler($self->{product}) unless $self->{product_handler};
1048 3 50       7 croak "Cannot autodetect server product" unless $self->{product};
1049 3         9 return $self->{product_handler};
1050             }
1051              
1052             sub _autodetect_product {
1053 2     2   3 my $self = shift;
1054 2         6 for my $id (@PRODUCT_HANDLER_ORDERING) {
1055              
1056 4         38 my $handler = $self->_new_handler($id);
1057 4 100       16 return ($id,$handler) if $handler->autodetect();
1058             }
1059 0         0 return undef;
1060             }
1061              
1062             sub _new_handler {
1063 5     5   7 my $self = shift;
1064 5         8 my $product = shift;
1065              
1066 5         301 my $handler = eval $PRODUCT_HANDLER{$product}."->new(\$self)";
1067 5 50       14 croak "Cannot create handler ",$self->{product},": $@" if $@;
1068 5         10 return $handler;
1069             }
1070              
1071              
1072             my $SPACE = 4;
1073             my @SEPS = (":");
1074             my $CURRENT_DOMAIN = "";
1075              
1076             sub _format_map {
1077 0     0   0 my ($ret,$map,$path,$level) = @_;
1078              
1079 0         0 my $p = shift @$path;
1080 0 0       0 my $sep = $SEPS[$level] ? $SEPS[$level] : "";
1081 0 0       0 if ($p) {
1082 0         0 $ret .= "$p".$sep;
1083 0 0       0 if (!@$path) {
1084 0         0 my $s = length($ret);
1085 0         0 $ret .= "\n".("=" x length($ret))."\n\n";
1086             }
1087 0         0 $ret = &_format_map($ret,$map,$path,$level);
1088             } else {
1089 0         0 for my $d (keys %$map) {
1090 0         0 my $prefix = "";
1091 0 0       0 if ($level == 0) {
    0          
1092 0         0 $CURRENT_DOMAIN = $d;
1093             } elsif ($level == 1) {
1094 0         0 $prefix = $CURRENT_DOMAIN . ":";
1095             }
1096 0 0 0     0 $ret .= &_get_space($level).$prefix.$d.$sep."\n" unless ($d eq "attr" || $d eq "op" || $d eq "error" || $d eq "desc");
      0        
      0        
1097 0         0 my @args = ($ret,$map->{$d},$path);
1098 0 0       0 if ($d eq "attr") {
    0          
    0          
    0          
1099 0         0 $ret = &_format_attr_or_op(@args,$level,"attr","Attributes",\&_format_attribute);
1100             } elsif ($d eq "op") {
1101 0         0 $ret = &_format_attr_or_op(@args,$level,"op","Operations",\&_format_operation);
1102             } elsif ($d eq "desc") {
1103             # TODO: Print out description of an MBean
1104             } elsif ($d eq "error") {
1105 0         0 $ret = $ret . "\nError: ".$map->{error}->{message}."\n";
1106             } else {
1107 0         0 $ret = &_format_map(@args,$level+1);
1108 0 0       0 if ($level == 0) {
    0          
1109 0         0 $ret .= "-" x 80 . "\n";
1110             } elsif ($level == 1) {
1111 0         0 $ret .= "\n";
1112             }
1113             }
1114             }
1115             }
1116 0         0 return $ret;
1117             }
1118              
1119             sub _format_attr_or_op {
1120 0     0   0 my ($ret,$map,$path,$level,$top_key,$label,$format_sub) = @_;
1121              
1122 0         0 my $p = shift @$path;
1123 0 0       0 if ($p eq $top_key) {
1124 0         0 $p = shift @$path;
1125 0 0       0 if ($p) {
1126 0         0 $ret .= " ".$p."\n";
1127 0         0 return $format_sub->($ret,$p,$map->{$p},$level);
1128             } else {
1129 0         0 $ret .= " $label:\n";
1130             }
1131             } else {
1132 0         0 $ret .= &_get_space($level)."$label:\n";
1133             }
1134 0         0 for my $key (keys %$map) {
1135 0         0 $ret = $format_sub->($ret,$key,$map->{$key},$level+1);
1136             }
1137 0         0 return $ret;
1138             }
1139              
1140             sub _format_attribute {
1141 0     0   0 my ($ret,$name,$attr,$level) = @_;
1142 0         0 $ret .= &_get_space($level);
1143 0 0 0     0 $ret .= sprintf("%-35s %s\n",$name,$attr->{type}.((!$attr->{rw} || "false" eq lc $attr->{rw}) ? " [ro]" : "").", \"".$attr->{desc}."\"");
1144 0         0 return $ret;
1145             }
1146              
1147             sub _format_operation {
1148 0     0   0 my ($ret,$name,$op,$level) = @_;
1149 0         0 $ret .= &_get_space($level);
1150 0 0       0 my $list = ref($op) eq "HASH" ? [ $op ] : $op;
1151 0         0 my $first = 1;
1152 0         0 for my $o (@$list) {
1153 0         0 my $method = &_format_method($name,$o->{args},$o->{ret});
1154 0 0       0 $ret .= &_get_space($level) unless $first;
1155 0         0 $ret .= sprintf("%-35s \"%s\"\n",$method,$o->{desc});
1156 0         0 $first = 0;
1157             }
1158 0         0 return $ret;
1159             }
1160              
1161             sub _format_method {
1162 0     0   0 my ($name,$args,$ret_type) = @_;
1163 0         0 my $ret = $ret_type." ".$name."(";
1164 0 0       0 if ($args) {
1165 0         0 for my $a (@$args) {
1166 0         0 $ret .= $a->{type} . " " . $a->{name} . ",";
1167             }
1168 0 0       0 chop $ret if @$args;
1169             }
1170 0         0 $ret .= ")";
1171 0         0 return $ret;
1172             }
1173              
1174             sub _get_space {
1175 0     0   0 my $level = shift;
1176 0         0 return " " x ($level * $SPACE);
1177             }
1178              
1179             sub cfg {
1180 12     12 0 19 my $self = shift;
1181 12         18 my $key = shift;
1182 12         14 my $val = shift;
1183 12         33 my $ret = $self->{cfg}->{$key};
1184 12 50       31 if (defined $val) {
1185 0         0 $self->{cfg}->{$key} = $val;
1186             }
1187 12         36 return $ret;
1188             }
1189              
1190             # ==========================================================================
1191             # Methods used for overwriting
1192              
1193             # Init method called during construction
1194 0     0 0 0 sub init {
1195             # Do nothing by default
1196             }
1197              
1198             # ==========================================================================
1199             #
1200              
1201             sub autodiscover_mode {
1202              
1203             # For now, only *one* mode is supported. Additional
1204             # could be added (like calling up a local JVM)
1205 4     4 0 18 return "agent";
1206             }
1207              
1208             =back
1209              
1210             =head1 LICENSE
1211              
1212             This file is part of jmx4perl.
1213              
1214             Jmx4perl is free software: you can redistribute it and/or modify
1215             it under the terms of the GNU General Public License as published by
1216             the Free Software Foundation, either version 2 of the License, or
1217             (at your option) any later version.
1218              
1219             jmx4perl is distributed in the hope that it will be useful,
1220             but WITHOUT ANY WARRANTY; without even the implied warranty of
1221             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1222             GNU General Public License for more details.
1223              
1224             You should have received a copy of the GNU General Public License
1225             along with jmx4perl. If not, see .
1226              
1227             A commercial license is available as well. Please contact roland@cpan.org for
1228             further details.
1229              
1230             =head1 PROFESSIONAL SERVICES
1231              
1232             Just in case you need professional support for this module (or Nagios or JMX in
1233             general), you might want to have a look at
1234             http://www.consol.com/opensource/nagios/. Contact roland.huss@consol.de for
1235             further information (or use the contact form at http://www.consol.com/contact/)
1236              
1237             =head1 AUTHOR
1238              
1239             roland@cpan.org
1240              
1241             =cut
1242              
1243             1;