1244 lines
39 KiB
Perl
1244 lines
39 KiB
Perl
#!/usr/bin/perl
|
|
|
|
=head1 NAME
|
|
|
|
JMX::Jmx4Perl - JMX access for Perl
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
Simple:
|
|
|
|
use strict;
|
|
use JMX::Jmx4Perl;
|
|
use JMX::Jmx4Perl::Alias; # Import MBean aliases
|
|
|
|
print "Memory Used: ",
|
|
JMX::Jmx4Perl
|
|
->new(url => "http://localhost:8080/j4p")
|
|
->get_attribute(MEMORY_HEAP_USED);
|
|
|
|
Advanced:
|
|
|
|
use strict;
|
|
use JMX::Jmx4Perl;
|
|
use JMX::Jmx4Perl::Request; # Type constants are exported here
|
|
|
|
my $jmx = new JMX::Jmx4Perl(url => "http://localhost:8080/j4p",
|
|
product => "jboss");
|
|
my $request = new JMX::Jmx4Perl::Request({type => READ,
|
|
mbean => "java.lang:type=Memory",
|
|
attribute => "HeapMemoryUsage",
|
|
path => "used"});
|
|
my $response = $jmx->request($request);
|
|
print "Memory used: ",$response->value(),"\n";
|
|
|
|
# Get general server information
|
|
print "Server Info: ",$jmx->info();
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Jmx4Perl is here to connect the Java and Perl Enterprise world by providing
|
|
transparent access to the Java Management Extensions (JMX) from the perl side.
|
|
|
|
It uses a traditional request-response paradigma for performing JMX operations
|
|
on a remote Java Virtual machine.
|
|
|
|
There a various ways how JMX information can be transfered. Jmx4Perl is based
|
|
on a Jolokia I<agent> (www.jolokia.org), which needs to deployed on the target
|
|
platform. It plays the role of a proxy, which on one side communicates with the
|
|
MBeanServer within in the application server and transfers JMX related
|
|
information via HTTP and JSON to the client (i.e. this module). Please refer to
|
|
L<JMX::Jmx4Perl::Manual> for installation instructions for how to deploy the
|
|
Jolokia agent.
|
|
|
|
An alternative and more 'java like' approach is the usage of JSR 160
|
|
connectors. However, the default connectors provided by the Java Virtual
|
|
Machine (JVM) since version 1.5 support only proprietary protocols which
|
|
require serialized Java objects to be exchanged. This implies that a JVM needs
|
|
to be started on the client side adding quite some overhead if used from within
|
|
Perl. If you absolutely require JSR 160 communication (e.g. because a agent can
|
|
not be deployed on the target for some reason), you can still use Jmx4Perl
|
|
operating with the so called I<proxy mode>.
|
|
|
|
For further discussion comparing both approaches, please refer to
|
|
L<JMX::Jmx4Perl::Manual>
|
|
|
|
JMX itself knows about the following operations on so called I<MBeans>, which
|
|
are specific "managed beans" designed for JMX and providing access to
|
|
management functions:
|
|
|
|
=over
|
|
|
|
=item *
|
|
|
|
Reading and writing of attributes of an MBean (like memory usage or connected
|
|
users)
|
|
|
|
=item *
|
|
|
|
Executing of exposed operations (like triggering a garbage collection)
|
|
|
|
=item *
|
|
|
|
Registering of notifications which are send from the application server to a
|
|
listener when a certain event happens.
|
|
|
|
=back
|
|
|
|
=head1 METHODS
|
|
|
|
=over
|
|
|
|
=cut
|
|
|
|
package JMX::Jmx4Perl;
|
|
|
|
use Carp;
|
|
use JMX::Jmx4Perl::Request;
|
|
use JMX::Jmx4Perl::Config;
|
|
use strict;
|
|
use vars qw($VERSION $HANDLER_BASE_PACKAGE @PRODUCT_HANDLER_ORDERING);
|
|
use Data::Dumper;
|
|
use Module::Find;
|
|
use JSON;
|
|
|
|
$VERSION = "1.12";
|
|
|
|
my $REGISTRY = {
|
|
# Agent based
|
|
"agent" => "JMX::Jmx4Perl::Agent",
|
|
"JMX::Jmx4Perl::Agent" => "JMX::Jmx4Perl::Agent",
|
|
"JJAgent" => "JMX::Jmx4Perl::Agent",
|
|
};
|
|
|
|
my %PRODUCT_HANDLER;
|
|
|
|
sub _register_handlers {
|
|
my $handler_package = shift;
|
|
%PRODUCT_HANDLER = ();
|
|
|
|
my @id2order = ();
|
|
for my $handler (findsubmod $handler_package) {
|
|
next unless $handler;
|
|
my $handler_file = $handler;
|
|
$handler_file =~ s|::|/|g;
|
|
require $handler_file.".pm";
|
|
next if $handler eq $handler_package."::BaseHandler";
|
|
my $id = eval "${handler}::id()";
|
|
die "No id() method on $handler: $@" if $@;
|
|
$PRODUCT_HANDLER{lc $id} = $handler;
|
|
push @id2order, [ lc $id, $handler->order() ];
|
|
}
|
|
# Ordering Schema according to $handler->order():
|
|
# -10,-5,-3,0,undef,undef,undef,1,8,9,1000
|
|
my @high = map { $_->[0] } sort { $a->[1] <=> $b->[1] } grep { defined($_->[1]) && $_->[1] <= 0 } @id2order;
|
|
my @med = map { $_->[0] } grep { not defined($_->[1]) } @id2order;
|
|
my @low = map { $_->[0] } sort { $a->[1] <=> $b->[1] } grep { defined($_->[1]) && $_->[1] > 0 } @id2order;
|
|
@PRODUCT_HANDLER_ORDERING = (@high,@med,@low);
|
|
}
|
|
|
|
BEGIN {
|
|
&_register_handlers("JMX::Jmx4Perl::Product");
|
|
}
|
|
|
|
|
|
=item $jmx = JMX::Jmx4Perl->new(mode => <access module>, ....)
|
|
|
|
Create a new instance. The call is dispatched to an Jmx4Perl implementation by
|
|
selecting an appropriate mode. For now, the only mode supported is "agent",
|
|
which uses the L<JMX::Jmx4Perl::Agent> backend. Hence, the mode can be
|
|
submitted for now.
|
|
|
|
Options can be given via key value pairs (or via a hash). Recognized options
|
|
are:
|
|
|
|
=over
|
|
|
|
=item server
|
|
|
|
You can provide a server name which is looked up in a configuration file. The
|
|
configuration file's name can be given via C<config_file> (see below) or, by
|
|
default, C<.j4p> in the users home directory is used.
|
|
|
|
=item config_file
|
|
|
|
Path to a configuration file to use
|
|
|
|
=item config
|
|
|
|
A L<JMX::Jmx4Perl::Config> object which is used for
|
|
configuraton. Use this is you already read in the
|
|
configuration on your own.
|
|
|
|
=item product
|
|
|
|
If you provide a product id via the named parameter C<product> you can given
|
|
B<jmx4perl> a hint which server you are using. By default, this module uses
|
|
autodetection to guess the kind of server you are talking to. You need to
|
|
provide this argument only if you use B<jmx4perl>'s alias feature and if you
|
|
want to speed up things (autodetection can be quite slow since this requires
|
|
several JMX request to detect product specific MBean attributes).
|
|
|
|
=item timeout
|
|
|
|
Timeout in seconds for an HTTP request
|
|
|
|
=item method
|
|
|
|
Default HTTP method to use for requests which can be overridden for each
|
|
specific request
|
|
|
|
=back
|
|
|
|
Any other named parameters are interpreted by the backend, please
|
|
refer to its documentation for details (i.e. L<JMX::Jmx4Perl::Agent>)
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $cfg = ref($_[0]) eq "HASH" ? $_[0] : { @_ };
|
|
|
|
# Merge in config from a configuration file if a server name is given
|
|
if ($cfg->{server}) {
|
|
my $config = $cfg->{config} ? $cfg->{config} : new JMX::Jmx4Perl::Config($cfg->{config_file});
|
|
my $server_cfg = $config->get_server_config($cfg->{server});
|
|
if (defined($server_cfg)) {
|
|
$cfg = { %$server_cfg, %$cfg };
|
|
}
|
|
}
|
|
|
|
my $mode = delete $cfg->{mode} || autodiscover_mode();
|
|
my $product = $cfg->{product} ? lc delete $cfg->{product} : undef;
|
|
|
|
$class = $REGISTRY->{$mode} || croak "Unknown runtime mode " . $mode;
|
|
if ($product && !$PRODUCT_HANDLER{lc $product}) {
|
|
die "No handler for product '$product'. Known Handlers are [".(join ", ",keys %PRODUCT_HANDLER)."]";
|
|
}
|
|
|
|
eval "require $class";
|
|
croak "Cannot load $class: $@" if $@;
|
|
|
|
my $self = {
|
|
cfg => $cfg,
|
|
product => $product
|
|
};
|
|
bless $self,(ref($class) || $class);
|
|
$self->init();
|
|
return $self;
|
|
}
|
|
|
|
# ==========================================================================
|
|
|
|
=item $value => $jmx->get_attribute(...)
|
|
|
|
$value = $jmx->get_attribute($mbean,$attribute,$path)
|
|
$value = $jmx->get_attribute($alias)
|
|
$value = $jmx->get_attribute(ALIAS) # Literal alias as defined in
|
|
# JMX::Jmx4Perl::Alias
|
|
$value = $jmx->get_attribute({ domain => <domain>,
|
|
properties => { <key> => value },
|
|
attribute => <attribute>,
|
|
path => <path> })
|
|
$value = $jmx->get_attribute({ alias => <alias>,
|
|
path => <path })
|
|
|
|
Read a JMX attribute. In the first form, you provide the MBean name, the
|
|
attribute name and an optional path as positional arguments. The second
|
|
variant uses named parameters from a hashref.
|
|
|
|
The Mbean name can be specified with the canonical name (key C<mbean>), or with
|
|
a domain name (key C<domain>) and one or more properties (key C<properties> or
|
|
C<props>) which contain key-value pairs in a Hashref. For more about naming of
|
|
MBeans please refer to
|
|
L<http://java.sun.com/j2se/1.5.0/docs/api/javax/management/ObjectName.html> for
|
|
more information about JMX naming.
|
|
|
|
Alternatively, you can provide an alias, which gets resolved to its real name
|
|
by so called I<product handler>. Several product handlers are provided out of
|
|
the box. If you have specified a C<product> id during construction of this
|
|
object, the associated handler is selected. Otherwise, autodetection is used to
|
|
guess the product. Note, that autodetection is potentially slow since it
|
|
involves several JMX calls to the server. If you call with a single, scalar
|
|
value, this argument is taken as alias (without any path). If you want to use
|
|
aliases together with a path, you need to use the second form with a hash ref
|
|
for providing the (named) arguments.
|
|
|
|
Additionally you can use a pattern and/or an array ref for attributes to
|
|
combine multiple reads into a single request. With an array ref as attribute
|
|
argument, all the given attributes are queried. If C<$attribute> is C<undef>
|
|
all attributes on the MBean are queried.
|
|
|
|
If you provide a pattern as described for the L<"/search"> method, a search
|
|
will be performed on the server side, an for all MBeans found which carry the
|
|
given attribute(s), their value will be returned. Attributes which doesn't
|
|
apply to an MBean are ignored.
|
|
|
|
Note, that the C<path> feature is not available when using MBean patterns or
|
|
multiple values.
|
|
|
|
Depending on the arguments, this method return value has a different format:
|
|
|
|
=over 4
|
|
|
|
=item Single MBean, single attribute
|
|
|
|
The return value is the result of the serverside read operation. It will throw
|
|
an exception (die), if an error occurs on the server side, e.g. when the name
|
|
couldn't be found.
|
|
|
|
Example:
|
|
|
|
$val = $jmx->get_attribute("java.lang:type=Memory","HeapMemoryUsage");
|
|
print Dumper($val);
|
|
|
|
{
|
|
committed => 174530560,
|
|
init => 134217728,
|
|
max => "1580007424",
|
|
used => 35029320
|
|
}
|
|
|
|
=item Single MBean, multiple attributes
|
|
|
|
In this case, this method returns a map with the attribute name as keys and the
|
|
attribute values as map values. It will die if not a single attribute could be
|
|
fetched, otherwise unknown attributes are ignored.
|
|
|
|
$val = $jmx->get_attribute(
|
|
"java.lang:type=Memory",
|
|
["HeapMemoryUsage","NonHeapMemoryUsage"]
|
|
);
|
|
print Dumper($val);
|
|
|
|
{
|
|
HeapMemoryUsage => {
|
|
committed => 174530560,
|
|
init => 134217728,
|
|
max => "1580007424",
|
|
used => 37444832
|
|
},
|
|
NonHeapMemoryUsage => {
|
|
committed => 87552000,
|
|
init => 24317952,
|
|
max => 218103808,
|
|
used => 50510976
|
|
}
|
|
}
|
|
|
|
=item MBean pattern, one or more attributes
|
|
|
|
$val = $jmx->get_attribute(
|
|
"java.lang:type=*",
|
|
["HeapMemoryUsage","NonHeapMemoryUsage"]
|
|
);
|
|
print Dumper($val);
|
|
|
|
{
|
|
"java.lang:type=Memory" => {
|
|
HeapMemoryUsage => {
|
|
committed => 174530560,
|
|
init => 134217728,
|
|
max => "1580007424",
|
|
used => 38868584
|
|
},
|
|
NonHeapMemoryUsage => {
|
|
committed => 87552000,
|
|
init => 24317952,
|
|
max => 218103808,
|
|
used => 50514304
|
|
}
|
|
}
|
|
}
|
|
|
|
The return value is a map with the matching MBean names as keys and as value
|
|
another map, with attribute names keys and attribute value values. If not a
|
|
singel MBean matches or not a single attribute can be found on the matching
|
|
MBeans this method dies. This format is the same whether you are using a single
|
|
attribute or an array ref of attribute names.
|
|
|
|
=back
|
|
|
|
Please don't overuse pattern matching (i.e. don't use patterns like "*:*"
|
|
except you really want to) since this could easily blow up your Java
|
|
application. The return value is generated completely in memory. E.g if you
|
|
want to retrieve all attributes for Weblogic with
|
|
|
|
$jmx->get_attribute("*:*",undef);
|
|
|
|
you will load more than 200 MB in to the Heap. Probably not something you
|
|
want to do. So please be nice to your appserver and use a more restrictive
|
|
pattern.
|
|
|
|
=cut
|
|
|
|
sub get_attribute {
|
|
my $self = shift;
|
|
my ($object,$attribute,$path) = $self->_extract_get_set_parameters(with_value => 0,params => [@_]);
|
|
croak "No object name provided" unless $object;
|
|
|
|
my $response;
|
|
if (ref($object) eq "CODE") {
|
|
$response = $self->delegate_to_handler($object);
|
|
} else {
|
|
#croak "No attribute provided for object $object" unless $attribute;
|
|
my $request = JMX::Jmx4Perl::Request->new(READ,$object,$attribute,$path);
|
|
$response = $self->request($request);
|
|
# print Dumper($response);
|
|
}
|
|
if ($response->is_error) {
|
|
my $a = ref($attribute) eq "ARRAY" ? "[" . join(",",@$attribute) . "]" : $attribute;
|
|
my $o = "(".$object.",".$a.($path ? "," . $path : "").")";
|
|
croak "The attribute $o is not registered on the server side"
|
|
if $response->status == 404;
|
|
croak "Error requesting $o: ",$response->error_text;
|
|
}
|
|
return $response->value;
|
|
}
|
|
|
|
=item $resp = $jmx->set_attribute(...)
|
|
|
|
$new_value = $jmx->set_attribute($mbean,$attribute,$value,$path)
|
|
$new_value = $jmx->set_attribute($alias,$value)
|
|
$new_value = $jmx->set_attribute(ALIAS,$value) # Literal alias as defined in
|
|
# JMX::Jmx4Perl::Alias
|
|
$new_value = $jmx->set_attribute({ domain => <domain>,
|
|
properties => { <key> => value },
|
|
attribute => <attribute>,
|
|
value => <value>,
|
|
path => <path> })
|
|
$new_value = $jmx->set_attribute({ alias => <alias>,
|
|
value => <value>,
|
|
path => <path })
|
|
|
|
Method for writing an attribute. It has the same signature as L</get_attribute>
|
|
except that it takes an additional parameter C<value> for setting the value. It
|
|
returns the old value of the attribute (or the object pointed to by an inner
|
|
path).
|
|
|
|
As for C<get_attribute> you can use a path to specify an inner part of a more
|
|
complex data structure. The value is tried to set on the inner object which is
|
|
pointed to by the given path.
|
|
|
|
Please note that only basic data types can be set this way. I.e you can set
|
|
only values of the following types
|
|
|
|
=over
|
|
|
|
=item C<java.lang.String>
|
|
|
|
=item C<java.lang.Boolean>
|
|
|
|
=item C<java.lang.Integer>
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub set_attribute {
|
|
my $self = shift;
|
|
|
|
my ($object,$attribute,$path,$value) =
|
|
$self->_extract_get_set_parameters(with_value => 1,params => [@_]);
|
|
croak "No object name provided" unless $object;
|
|
my $response;
|
|
if (ref($object) eq "CODE") {
|
|
$response = $self->delegate_to_handler($object,$value);
|
|
} else {
|
|
croak "No attribute provided for object $object" unless $attribute;
|
|
croak "No value to set provided for object $object and attribute $attribute" unless defined($value);
|
|
my $request = JMX::Jmx4Perl::Request->new(WRITE,$object,$attribute,$value,$path);
|
|
$response = $self->request($request);
|
|
}
|
|
if ($response->status == 404) {
|
|
return undef;
|
|
}
|
|
return $response->value;
|
|
}
|
|
|
|
=item $info = $jmx->info($verbose)
|
|
|
|
Get a textual description of the server as returned by a product specific
|
|
handler (see L<JMX::Jmx4Perl::Product::BaseHandler>). It uses the
|
|
autodetection facility if no product is given explicitely during construction.
|
|
|
|
If C<$verbose> is true, print even more information
|
|
|
|
=cut
|
|
|
|
sub info {
|
|
my $self = shift;
|
|
my $verbose = shift;
|
|
my $handler = $self->{product_handler} || $self->_create_handler();
|
|
return $handler->info($verbose);
|
|
}
|
|
|
|
|
|
=item $mbean_list = $jmx->search($mbean_pattern)
|
|
|
|
Search for MBean based on a pattern and return a reference to the list of found
|
|
MBeans names (as string). If no MBean can be found, C<undef> is returned. For
|
|
example,
|
|
|
|
$jmx->search("*:j2eeType=J2EEServer,*")
|
|
|
|
searches all MBeans whose name are matching this pattern, which are according
|
|
to JSR77 all application servers in all available domains.
|
|
|
|
=cut
|
|
|
|
sub search {
|
|
my $self = shift;
|
|
my $pattern = shift || croak "No pattern provided";
|
|
|
|
my $request = new JMX::Jmx4Perl::Request(SEARCH,$pattern);
|
|
my $response = $self->request($request);
|
|
|
|
# An error of 404 was the behaviour of Jolokia < 0.90,
|
|
# for > 0.90 an empty list was returned
|
|
return undef if $response->status == 404;
|
|
if ($response->is_error) {
|
|
die "Error searching for $pattern: ",$response->error_text;
|
|
}
|
|
my $val = $response->value;
|
|
return ref($val) eq "ARRAY" && @$val ? $val : undef;
|
|
}
|
|
|
|
=item $ret = $jmx->execute(...)
|
|
|
|
$ret = $jmx->execute($mbean,$operation,$arg1,$arg2,...)
|
|
$ret = $jmx->execute(ALIAS,$arg1,$arg2,...)
|
|
|
|
$value = $jmx->execute({ domain => <domain>,
|
|
properties => { <key> => value },
|
|
operation => <operation>,
|
|
arguments => [ <arg1>, <arg2>, ... ] })
|
|
$value = $jmx->execute({ alias => <alias>,
|
|
arguments => [ <arg1,<arg2>, .... ]})
|
|
|
|
Execute a JMX operation with the given arguments. If used in the second form,
|
|
with an alias as first argument, it is recommended to use the constant as
|
|
exported by L<JMX::Jmx4Perl::Alias>, otherwise it is guessed, whether the first
|
|
string value is an alias or a MBean name. To be sure, use the variant with an
|
|
hashref as argument.
|
|
|
|
If you are calling an overloaded JMX operation (i.e. operations with the same
|
|
name but a different argument signature), the operation name must include the
|
|
signature as well. This is be done by adding the parameter types comma
|
|
separated within parentheses:
|
|
|
|
...
|
|
operation => "overloadedMethod(java.lang.String,int)"
|
|
...
|
|
|
|
This method will croak, if something fails during execution of this
|
|
operation or when the MBean/Operation combination could not be found.
|
|
|
|
The return value of this method is the return value of the JMX operation.
|
|
|
|
=cut
|
|
|
|
sub execute {
|
|
my $self = shift;
|
|
|
|
my @args = @_;
|
|
my ($mbean,$operation,$op_args) = $self->_extract_execute_parameters(@_);
|
|
my $response;
|
|
if (ref($mbean) eq "CODE") {
|
|
$response = $self->delegate_to_handler($mbean,@{$op_args});
|
|
} else {
|
|
my $request = new JMX::Jmx4Perl::Request(EXEC,$mbean,$operation,@{$op_args});
|
|
$response = $self->request($request);
|
|
}
|
|
if ($response->is_error) {
|
|
croak "No MBean ".$mbean." with operation ".$operation.
|
|
(@$op_args ? " (Args: [".join(",",@$op_args)."]" : "").") found on the server side"
|
|
if $response->status == 404;
|
|
croak "Error executing operation $operation on MBean $mbean: ",$response->error_text;
|
|
}
|
|
return $response->value;
|
|
}
|
|
|
|
|
|
=item $resp = $jmx->version()
|
|
|
|
This method return the version of the agent as well as the j4p protocol
|
|
version. The agent's version is a regular program version and corresponds to
|
|
jmx4perl's version from which the agent has been taken. The protocol version
|
|
is an integer number which indicates the version of the protocol specification.
|
|
|
|
The return value is a hash with the keys C<agent> and C<protocol>
|
|
|
|
=cut
|
|
|
|
sub version {
|
|
my $self = shift;
|
|
|
|
my $request = new JMX::Jmx4Perl::Request(AGENT_VERSION);
|
|
my $response = $self->request($request);
|
|
|
|
if ($response->is_error) {
|
|
die "Error getting the agent's version: ",$response->error_text;
|
|
}
|
|
|
|
return $response->value;
|
|
}
|
|
|
|
=item $resp = $jmx->request($request)
|
|
|
|
Send a request to the underlying agent and return the response. This is an
|
|
abstract method which needs to be overwritten by a subclass. The argument must
|
|
be of type L<JMX::Jmx4Perl::Request> and it returns an object of type
|
|
L<JMX::Jmx4Perl::Response>.
|
|
|
|
=cut
|
|
|
|
sub request {
|
|
croak "Internal: Must be overwritten by a subclass";
|
|
}
|
|
|
|
=item $agents = JMX::Jmx4Perl->discover_agents($timeout)
|
|
|
|
Discover agents by sending a multicast request on which Jolokia agents are
|
|
listening. The optional C<$timeout> can be used to tune how long to wait for
|
|
discovery answers (in seconds). By default 1 seconds is waited. This functionality
|
|
requires L<IO::Socket::Multicast> to be installed.
|
|
|
|
This methods returns an array ref, which looks like
|
|
|
|
[
|
|
{
|
|
'version' => '1.2.0-SNAPSHOT',
|
|
'server_version' => '7.0.50',
|
|
'server_product' => 'tomcat',
|
|
'secured' => 0,
|
|
'url' => 'http://10.9.11.2:8778/jolokia/',
|
|
'server_vendor' => 'Apache',
|
|
'confidence' => 100,
|
|
'type' => 'response'
|
|
}
|
|
]
|
|
|
|
Please refer to Jolokia's reference documentation for the meaning of the keys.
|
|
The most important part it C<url> which points to the agent's URL which can
|
|
be used to construct a new L<JMX::Jmx4Perl> object.
|
|
|
|
=cut
|
|
|
|
|
|
sub discover_agents {
|
|
my $self = shift;
|
|
my $timeout = shift | 1;
|
|
|
|
my $s;
|
|
eval {
|
|
$s = IO::Socket::Multicast->new();
|
|
};
|
|
if ($@) {
|
|
eval {
|
|
require "IO/Socket/Multicast.pm";
|
|
$s = IO::Socket::Multicast->new();
|
|
};
|
|
if ($@) {
|
|
die "No IO::Socket::Multicast installed\n";
|
|
}
|
|
}
|
|
|
|
$s->mcast_send('{"type" : "query"}',"239.192.48.84:24884");
|
|
|
|
my @result = ();
|
|
my $data;
|
|
LOOP:
|
|
while (1) {
|
|
eval {
|
|
local $SIG{ALRM} = sub { die "timeout\n" }; # NB: \n required
|
|
alarm $timeout;
|
|
$s->recv($data,8192);
|
|
push @result,from_json($data, {utf8 => 1} );
|
|
alarm 0;
|
|
};
|
|
if ($@) {
|
|
die unless $@ eq "timeout\n"; # propagate unexpected errors
|
|
# timed out
|
|
last LOOP;
|
|
}
|
|
}
|
|
return \@result;
|
|
}
|
|
|
|
# ===========================================================================
|
|
# Alias handling
|
|
|
|
=item ($object,$attribute,$path) = $self->resolve_alias($alias)
|
|
|
|
Resolve an alias for an attibute or operation. This is done by querying registered
|
|
product handlers for resolving an alias. This method will croak if a handler
|
|
could be found but not such alias is known by C<jmx4perl>.
|
|
|
|
If the C<product> was not set during construction, the first call to this
|
|
method will try to autodetect the server. If it cannot determine the proper
|
|
server it will throw an exception.
|
|
|
|
For an attribute, this method returns the object, attribute, path triple which
|
|
can be used for requesting the server or C<undef> if the handler can not
|
|
handle this alias.
|
|
|
|
For an operation, the MBean, method name and the (optional) path, which should be
|
|
applied to the return value, is returned or C<undef> if the handler cannot
|
|
handle this alias.
|
|
|
|
A handler can decide to handle the fetching of the alias value directly. In
|
|
this case, this metod returns the code reference which needs to be executed
|
|
with the handler as argument (see "delegate_to_handler") below.
|
|
|
|
=cut
|
|
|
|
sub resolve_alias {
|
|
my $self = shift;
|
|
my $alias = shift || croak "No alias provided";
|
|
|
|
my $handler = $self->{product_handler} || $self->_create_handler();
|
|
return $handler->alias($alias);
|
|
}
|
|
|
|
=item $do_support = $self->supports_alias($alias)
|
|
|
|
Test for checking whether a handler supports a certain alias.
|
|
|
|
=cut
|
|
|
|
sub supports_alias {
|
|
my ($object) = shift->resolve_alias(shift);
|
|
return $object ? 1 : 0;
|
|
}
|
|
|
|
=item $response = $self->delegate_to_handler($coderef,@args)
|
|
|
|
Execute a subroutine with the current handler as argument and returns the
|
|
return value of this subroutine. This method is used in conjunction with
|
|
C<resolve_alias> to allow handler a more sophisticated way to access the
|
|
MBeanServer. The method specified by C<$coderef> must return a
|
|
L<JMX::Jmx4Perl::Response> as answer.
|
|
|
|
The subroutine is supposed to handle reading and writing of attributes and
|
|
execution of operations. Optional additional parameters are given to the subref
|
|
as additional arguments.
|
|
|
|
=cut
|
|
|
|
sub delegate_to_handler {
|
|
my $self = shift;
|
|
my $code = shift;
|
|
my $handler = $self->{product_handler} || $self->_create_handler();
|
|
return &{$code}($handler,@_);
|
|
}
|
|
|
|
=item $product = $self->product()
|
|
|
|
For supported application servers, this methods returns product handler
|
|
which is an object of type L<JMX::Jmx4Perl::Product::BaseHandler>.
|
|
|
|
This product is either detected automatically or provided during
|
|
construction time.
|
|
|
|
The most interesting methods on this object are C<id()>, C<name()> and
|
|
C<version()>
|
|
|
|
=cut
|
|
|
|
sub product {
|
|
my $self = shift;
|
|
my $handler = $self->{product_handler} || $self->_create_handler();
|
|
return $handler;
|
|
}
|
|
|
|
=item $value = $jmx->list($path)
|
|
|
|
Get all MBeans as registered at the specified server. A C<$path> can be
|
|
specified in order to fetchy only a subset of the information. When no path is
|
|
given, the returned value has the following format
|
|
|
|
$value = {
|
|
<domain> =>
|
|
{
|
|
<canonical property list> =>
|
|
{
|
|
"attr" =>
|
|
{
|
|
<atrribute name> =>
|
|
{
|
|
desc => <description of attribute>
|
|
type => <java type>,
|
|
rw => true/false
|
|
},
|
|
....
|
|
},
|
|
"op" =>
|
|
{
|
|
<operation name> =>
|
|
{
|
|
desc => <description of operation>
|
|
ret => <return java type>
|
|
args =>
|
|
[
|
|
{
|
|
desc => <description>,
|
|
name => <name>,
|
|
type => <java type>
|
|
},
|
|
....
|
|
]
|
|
},
|
|
....
|
|
},
|
|
....
|
|
}
|
|
....
|
|
};
|
|
|
|
A complete path has the format C<"E<lt>domainE<gt>/E<lt>property
|
|
listE<gt>/("attribute"|"operation")/E<lt>indexE<gt>">
|
|
(e.g. C<java.lang/name=Code Cache,type=MemoryPool/attribute/0>). A path can be
|
|
provided partially, in which case the remaining map/array is returned. See also
|
|
L<JMX::Jmx4Perl::Agent::Protocol> for a more detailed discussion of inner
|
|
paths.
|
|
|
|
This method throws an exception if an error occurs.
|
|
|
|
=cut
|
|
|
|
sub list {
|
|
my $self = shift;
|
|
my $path = shift;
|
|
|
|
my $request = JMX::Jmx4Perl::Request->new(LIST,$path);
|
|
my $response = $self->request($request);
|
|
if ($response->is_error) {
|
|
my $txt = "Error while listing attributes: " . $response->error_text . "\n" .
|
|
"Status: " . $response->status . "\n";
|
|
#($response->stacktrace ? "\n" . $response->stacktrace . "\n" : "\n");
|
|
die $txt;
|
|
}
|
|
return $response->value;
|
|
}
|
|
|
|
|
|
=item ($domain,$attributes) = $jmx->parse_name($name)
|
|
|
|
Parse an object name into its domain and attribute part. If successful,
|
|
C<$domain> contains the domain part of the objectname, and C<$attribtutes> is a
|
|
hahsref to the attributes of the name with the attribute names as keys and the
|
|
attribute's values as values. This method returns C<undef> when the name could
|
|
not be parsed. Result of a C<search()> operation can be savely feed into this
|
|
method to get to the subparts of the name. JMX quoting is taken into account
|
|
properly, too.
|
|
|
|
Example:
|
|
|
|
my ($domain,$attrs) =
|
|
$jmx->parse_name("java.lang:name=Code Cache,type=MemoryPool");
|
|
print $domain,"\n",Dumper($attrs);
|
|
|
|
java.lang
|
|
{
|
|
name => "Code Cache",
|
|
type => "MemoryPool"
|
|
}
|
|
|
|
=cut
|
|
|
|
sub parse_name {
|
|
my $self = shift;
|
|
my $name = shift;
|
|
my $escaped = shift;
|
|
|
|
return undef unless $name =~ /:/;
|
|
my ($domain,$rest) = split(/:/,$name,2);
|
|
my $attrs = {};
|
|
while ($rest =~ s/([^=]+)\s*=\s*//) {
|
|
#print "R: $rest\n";
|
|
my $key = $1;
|
|
my $value = undef;
|
|
if ($rest =~ /^"/) {
|
|
$rest =~ s/("((\\"|[^"])+)")(\s*,\s*|$)//;
|
|
$value = $escaped ? $1 : $2;
|
|
# Unescape escaped chars
|
|
$value =~ s/\\([:",=*?])/$1/g unless $escaped;
|
|
} else {
|
|
if ($rest =~ s/([^,]+)(\s*,\s*|$)//) {
|
|
$value = $1;
|
|
}
|
|
}
|
|
return undef unless defined($value);
|
|
$attrs->{$key} = $value;
|
|
#print "K: $key V: $value\n";
|
|
}
|
|
# If there is something left, we were not successful
|
|
# in parsing the name
|
|
return undef if $rest;
|
|
return ($domain,$attrs);
|
|
}
|
|
|
|
|
|
=item $formatted_text = $jmx->formatted_list($path)
|
|
|
|
=item $formatted_text = $jmx->formatted_list($resp)
|
|
|
|
Get the a formatted string representing the MBeans as returnded by C<list()>.
|
|
C<$path> is the optional inner path for selecting only a subset of all mbean.
|
|
See C<list()> for more details. If called with a L<JMX::Jmx4Perl::Response>
|
|
object, the list and the optional path will be taken from the provided response
|
|
object and not fetched again from the server.
|
|
|
|
=cut
|
|
|
|
sub formatted_list {
|
|
my $self = shift;
|
|
my $path_or_resp = shift;
|
|
my $path;
|
|
my $list;
|
|
|
|
if ($path_or_resp && UNIVERSAL::isa($path_or_resp,"JMX::Jmx4Perl::Response")) {
|
|
$path = $path_or_resp->request->get("path");
|
|
$list = $path_or_resp->value;
|
|
} else {
|
|
$path = $path_or_resp;
|
|
$list = $self->list($path);
|
|
}
|
|
my @path = ();
|
|
@path = split m|/|,$path if $path;
|
|
#print Dumper(\@path);
|
|
croak "A path can be used only for a domain name or MBean name" if @path > 2;
|
|
my $intent = "";
|
|
my $ret = &_format_map("",$list,\@path,0);
|
|
}
|
|
|
|
|
|
# ===============================================================================================
|
|
|
|
# Helper method for extracting parameters for the set/get methods.
|
|
sub _extract_get_set_parameters {
|
|
my $self = shift;
|
|
my %args = @_;
|
|
my $p = $args{params};
|
|
my $f = $p->[0];
|
|
my $with_value = $args{with_value};
|
|
my ($object,$attribute,$path,$value);
|
|
if (ref($f) eq "HASH") {
|
|
$value = $f->{value};
|
|
if ($f->{alias}) {
|
|
my $alias_path;
|
|
($object,$attribute,$alias_path) =
|
|
$self->resolve_alias($f->{alias});
|
|
if (ref($object) eq "CODE") {
|
|
# Let the handler do it
|
|
return ($object,undef,undef,$args{with_value} ? $value : undef);
|
|
}
|
|
croak "No alias ",$f->{alias}," defined for handler ",$self->product->name unless $object;
|
|
if ($alias_path) {
|
|
$path = $f->{path} ? $f->{path} . "/" . $alias_path : $alias_path;
|
|
} else {
|
|
$path = $f->{path};
|
|
}
|
|
} else {
|
|
$object = $f->{mbean} || $self->_glue_mbean_name($f) ||
|
|
croak "No MBean name or domain + properties given";
|
|
$attribute = $f->{attribute};
|
|
$path = $f->{path};
|
|
}
|
|
} else {
|
|
if ( (@{$p} == 1 && !$args{with_value}) ||
|
|
(@{$p} == 2 && $args{with_value}) || $self->_is_alias($p->[0])) {
|
|
# A single argument can only be used as an alias
|
|
($object,$attribute,$path) =
|
|
$self->resolve_alias($f);
|
|
$value = $_[1];
|
|
if (ref($object) eq "CODE") {
|
|
# Let the handler do it
|
|
return ($object,undef,undef,$args{with_value} ? $value : undef);
|
|
}
|
|
croak "No alias ",$f," defined for handler ",$self->product->name unless $object;
|
|
} else {
|
|
if ($args{with_value}) {
|
|
($object,$attribute,$value,$path) = @{$p};
|
|
} else {
|
|
($object,$attribute,$path) = @{$p};
|
|
}
|
|
}
|
|
}
|
|
return ($object,$attribute,$path,$value);
|
|
}
|
|
|
|
sub _extract_execute_parameters {
|
|
my $self = shift;
|
|
my @args = @_;
|
|
my ($mbean,$operation,$op_args);
|
|
if (ref($args[0] eq "JMX::Jmx4Perl::Request")) {
|
|
die 'Use $j4p->request(), not $j4p->execute() for executing a JMX::Jmx4Perl::Request',"\n";
|
|
} elsif (ref($args[0]) eq "HASH") {
|
|
my $args = $args[0];
|
|
if ($args->{alias}) {
|
|
($mbean,$operation) = $self->resolve_alias($args->{alias});
|
|
if (ref($mbean) eq "CODE") {
|
|
# Alias handles this completely on its own
|
|
return ($mbean,undef,$args->{arguments} || $args->{args});
|
|
}
|
|
croak "No alias ",$args->{alias}," defined for handler ",$self->product->name unless $mbean;
|
|
} else {
|
|
$mbean = $args->{mbean} || $self->_glue_mbean_name($args) ||
|
|
croak "No MBean name or domain + properties given";
|
|
$operation = $args->{operation} || croak "No operation given";
|
|
}
|
|
$op_args = $args->{arguments} || $args->{args};
|
|
} else {
|
|
if ($self->_is_alias($args[0])) {
|
|
($mbean,$operation) = $self->resolve_alias($args[0]);
|
|
shift @args;
|
|
if (ref($mbean) eq "CODE") {
|
|
# Alias handles this completely on its own
|
|
return ($mbean,undef,[ @args ]);
|
|
}
|
|
croak "No alias ",$args[0]," defined for handler ",$self->product->name unless $mbean;
|
|
$op_args = [ @args ];
|
|
} else {
|
|
$mbean = shift @args;
|
|
$operation = shift @args;
|
|
$op_args = [ @args ];
|
|
}
|
|
}
|
|
return ($mbean,$operation,$op_args);
|
|
}
|
|
|
|
# Check whether the argument is possibly an alias
|
|
sub _is_alias {
|
|
my $self = shift;
|
|
my $alias = shift;
|
|
if (UNIVERSAL::isa($alias,"JMX::Jmx4Perl::Alias::Object")) {
|
|
return 1;
|
|
} elsif (JMX::Jmx4Perl::Alias->by_name($alias)) {
|
|
return 1;
|
|
} else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
sub _glue_mbean_name {
|
|
my $self = shift;
|
|
my $f = shift;
|
|
my $object = undef;
|
|
if ($f->{domain} && ($f->{properties} || $f->{props})) {
|
|
$object = $f->{domain} . ":";
|
|
my $href = $f->{properties} || $f->{props};
|
|
croak "'properties' is not a hashref" unless ref($href);
|
|
for my $k (keys %{$href}) {
|
|
$object .= $k . "=" . $href->{$k};
|
|
}
|
|
}
|
|
return $object;
|
|
}
|
|
|
|
sub _create_handler {
|
|
my $self = shift;
|
|
if (!$self->{product}) {
|
|
($self->{product},$self->{product_handler}) = $self->_autodetect_product();
|
|
}
|
|
# Create product handler if not created during autodetectiong (e.g. if the
|
|
# product has been set explicitely)
|
|
$self->{product_handler} = $self->_new_handler($self->{product}) unless $self->{product_handler};
|
|
croak "Cannot autodetect server product" unless $self->{product};
|
|
return $self->{product_handler};
|
|
}
|
|
|
|
sub _autodetect_product {
|
|
my $self = shift;
|
|
for my $id (@PRODUCT_HANDLER_ORDERING) {
|
|
|
|
my $handler = $self->_new_handler($id);
|
|
return ($id,$handler) if $handler->autodetect();
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub _new_handler {
|
|
my $self = shift;
|
|
my $product = shift;
|
|
|
|
my $handler = eval $PRODUCT_HANDLER{$product}."->new(\$self)";
|
|
croak "Cannot create handler ",$self->{product},": $@" if $@;
|
|
return $handler;
|
|
}
|
|
|
|
|
|
my $SPACE = 4;
|
|
my @SEPS = (":");
|
|
my $CURRENT_DOMAIN = "";
|
|
|
|
sub _format_map {
|
|
my ($ret,$map,$path,$level) = @_;
|
|
|
|
my $p = shift @$path;
|
|
my $sep = $SEPS[$level] ? $SEPS[$level] : "";
|
|
if ($p) {
|
|
$ret .= "$p".$sep;
|
|
if (!@$path) {
|
|
my $s = length($ret);
|
|
$ret .= "\n".("=" x length($ret))."\n\n";
|
|
}
|
|
$ret = &_format_map($ret,$map,$path,$level);
|
|
} else {
|
|
for my $d (keys %$map) {
|
|
my $prefix = "";
|
|
if ($level == 0) {
|
|
$CURRENT_DOMAIN = $d;
|
|
} elsif ($level == 1) {
|
|
$prefix = $CURRENT_DOMAIN . ":";
|
|
}
|
|
$ret .= &_get_space($level).$prefix.$d.$sep."\n" unless ($d eq "attr" || $d eq "op" || $d eq "error" || $d eq "desc");
|
|
my @args = ($ret,$map->{$d},$path);
|
|
if ($d eq "attr") {
|
|
$ret = &_format_attr_or_op(@args,$level,"attr","Attributes",\&_format_attribute);
|
|
} elsif ($d eq "op") {
|
|
$ret = &_format_attr_or_op(@args,$level,"op","Operations",\&_format_operation);
|
|
} elsif ($d eq "desc") {
|
|
# TODO: Print out description of an MBean
|
|
} elsif ($d eq "error") {
|
|
$ret = $ret . "\nError: ".$map->{error}->{message}."\n";
|
|
} else {
|
|
$ret = &_format_map(@args,$level+1);
|
|
if ($level == 0) {
|
|
$ret .= "-" x 80 . "\n";
|
|
} elsif ($level == 1) {
|
|
$ret .= "\n";
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
sub _format_attr_or_op {
|
|
my ($ret,$map,$path,$level,$top_key,$label,$format_sub) = @_;
|
|
|
|
my $p = shift @$path;
|
|
if ($p eq $top_key) {
|
|
$p = shift @$path;
|
|
if ($p) {
|
|
$ret .= " ".$p."\n";
|
|
return $format_sub->($ret,$p,$map->{$p},$level);
|
|
} else {
|
|
$ret .= " $label:\n";
|
|
}
|
|
} else {
|
|
$ret .= &_get_space($level)."$label:\n";
|
|
}
|
|
for my $key (keys %$map) {
|
|
$ret = $format_sub->($ret,$key,$map->{$key},$level+1);
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
sub _format_attribute {
|
|
my ($ret,$name,$attr,$level) = @_;
|
|
$ret .= &_get_space($level);
|
|
$ret .= sprintf("%-35s %s\n",$name,$attr->{type}.((!$attr->{rw} || "false" eq lc $attr->{rw}) ? " [ro]" : "").", \"".$attr->{desc}."\"");
|
|
return $ret;
|
|
}
|
|
|
|
sub _format_operation {
|
|
my ($ret,$name,$op,$level) = @_;
|
|
$ret .= &_get_space($level);
|
|
my $list = ref($op) eq "HASH" ? [ $op ] : $op;
|
|
my $first = 1;
|
|
for my $o (@$list) {
|
|
my $method = &_format_method($name,$o->{args},$o->{ret});
|
|
$ret .= &_get_space($level) unless $first;
|
|
$ret .= sprintf("%-35s \"%s\"\n",$method,$o->{desc});
|
|
$first = 0;
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
sub _format_method {
|
|
my ($name,$args,$ret_type) = @_;
|
|
my $ret = $ret_type." ".$name."(";
|
|
if ($args) {
|
|
for my $a (@$args) {
|
|
$ret .= $a->{type} . " " . $a->{name} . ",";
|
|
}
|
|
chop $ret if @$args;
|
|
}
|
|
$ret .= ")";
|
|
return $ret;
|
|
}
|
|
|
|
sub _get_space {
|
|
my $level = shift;
|
|
return " " x ($level * $SPACE);
|
|
}
|
|
|
|
sub cfg {
|
|
my $self = shift;
|
|
my $key = shift;
|
|
my $val = shift;
|
|
my $ret = $self->{cfg}->{$key};
|
|
if (defined $val) {
|
|
$self->{cfg}->{$key} = $val;
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
# ==========================================================================
|
|
# Methods used for overwriting
|
|
|
|
# Init method called during construction
|
|
sub init {
|
|
# Do nothing by default
|
|
}
|
|
|
|
# ==========================================================================
|
|
#
|
|
|
|
sub autodiscover_mode {
|
|
|
|
# For now, only *one* mode is supported. Additional
|
|
# could be added (like calling up a local JVM)
|
|
return "agent";
|
|
}
|
|
|
|
=back
|
|
|
|
=head1 LICENSE
|
|
|
|
This file is part of jmx4perl.
|
|
|
|
Jmx4perl is free software: you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation, either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
jmx4perl is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with jmx4perl. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
A commercial license is available as well. Please contact roland@cpan.org for
|
|
further details.
|
|
|
|
=head1 PROFESSIONAL SERVICES
|
|
|
|
Just in case you need professional support for this module (or Nagios or JMX in
|
|
general), you might want to have a look at
|
|
http://www.consol.com/opensource/nagios/. Contact roland.huss@consol.de for
|
|
further information (or use the contact form at http://www.consol.com/contact/)
|
|
|
|
=head1 AUTHOR
|
|
|
|
roland@cpan.org
|
|
|
|
=cut
|
|
|
|
1;
|