Imported Upstream version 1.12
This commit is contained in:
Mario Fetka
1243
lib/JMX/Jmx4Perl.pm
Normal file
1243
lib/JMX/Jmx4Perl.pm
Normal file
File diff suppressed because it is too large
Load Diff
486
lib/JMX/Jmx4Perl/Agent.pm
Normal file
486
lib/JMX/Jmx4Perl/Agent.pm
Normal file
@@ -0,0 +1,486 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Agent;
|
||||
|
||||
use JSON;
|
||||
use URI::Escape qw(uri_escape_utf8);
|
||||
use HTTP::Request;
|
||||
use Carp;
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG);
|
||||
use base qw(JMX::Jmx4Perl);
|
||||
use JMX::Jmx4Perl::Request;
|
||||
use JMX::Jmx4Perl::Response;
|
||||
use JMX::Jmx4Perl::Agent::UserAgent;
|
||||
use Data::Dumper;
|
||||
|
||||
|
||||
$VERSION = $JMX::Jmx4Perl::VERSION;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent - JSON-HTTP based acess to a remote JMX agent
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $agent = new JMX::Jmx4Perl(mode=>"agent", url => "http://jeeserver/j4p");
|
||||
my $answer = $agent->get_attribute("java.lang:type=Memory","HeapMemoryUsage");
|
||||
print Dumper($answer);
|
||||
|
||||
{
|
||||
request => {
|
||||
attribute => "HeapMemoryUsage",
|
||||
name => "java.lang:type=Memory"
|
||||
},
|
||||
status => 200,
|
||||
value => {
|
||||
committed => 18292736,
|
||||
init => 0,
|
||||
max => 532742144,
|
||||
used => 15348352
|
||||
}
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is not used directly, but via L<JMX::Jmx4Perl>, which acts as a
|
||||
proxy to this module. You can think of L<JMX::Jmx4Perl> as the interface which
|
||||
is backed up by this module. Other implementations (e.g.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $jjagent = JMX::Jmx4Perl::Agent->new(url => $url, ....)
|
||||
|
||||
Creates a new local agent for a given url
|
||||
|
||||
=over
|
||||
|
||||
=item url => <url to JEE server>
|
||||
|
||||
The url where the agent is deployed. This is a mandatory parameter. The url
|
||||
must include the context within the server, which is typically based on the
|
||||
name of the war archive. Example: C<http://localhost:8080/j4p> for a drop
|
||||
in deployment of the agent in a standard Tomcat's webapp directory.
|
||||
|
||||
=item timeout => <timeout>
|
||||
|
||||
Timeout in seconds after which a request should be stopped if it not suceeds
|
||||
within this time. This parameter is given through directly to the underlying
|
||||
L<LWP::UserAgent>
|
||||
|
||||
=item user => <user>, password => <password>
|
||||
|
||||
Credentials to use for the HTTP request
|
||||
|
||||
=item method => <method>
|
||||
|
||||
The HTTP method to use for contacting the agent. Must be either "GET" or
|
||||
"POST". This method is used, if the request to send dosen't specify the method
|
||||
and no other parameters forces a POST context.
|
||||
|
||||
=item proxy => { http => '<http_proxy>', https => '<https_proxy>', ... }
|
||||
|
||||
=item proxy => <http_proxy>
|
||||
|
||||
=item proxy => { url => <http_proxy> }
|
||||
|
||||
Optional proxy to use
|
||||
|
||||
=item proxy_user => <user>, proxy_password => <password>
|
||||
|
||||
Credentials to use for accessing the proxy
|
||||
|
||||
=item target
|
||||
|
||||
Add a target which is used for any request served by this object if not already
|
||||
a target is present in the request. This way you can setup the default target
|
||||
configuration if you are using the agent servlet as a proxy, e.g.
|
||||
|
||||
... target => { url => "service:jmx:...", user => "...", password => "..." }
|
||||
|
||||
=item legacy-escape
|
||||
|
||||
Before version 1.0 a quite strange escaping scheme is used, when the part of a
|
||||
GET requests contains a slash (/). Starting with 1.0 this scheme has changed,
|
||||
but in order to allow post 1.0 Jmx4perl clients acess pre 1.0 Jolokia agents,
|
||||
this option can be set to true to switch to the old escape mechanism.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
# HTTP Parameters to be used for transmitting the request
|
||||
my @PARAMS = ("maxDepth","maxCollectionSize","maxObjects","ignoreErrors");
|
||||
|
||||
# Regexp for detecting invalid chars which can not be used securily in pathinfos
|
||||
my $INVALID_PATH_CHARS = qr/%(5C|3F|3B|2F)/i; # \ ? ; /
|
||||
|
||||
# Init called by parent package within 'new' for specific initialization. See
|
||||
# above for the parameters recognized
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
croak "No URL provided" unless $self->cfg('url');
|
||||
my $ua = JMX::Jmx4Perl::Agent::UserAgent->new();
|
||||
$ua->jjagent_config($self->{cfg});
|
||||
#push @{ $ua->requests_redirectable }, 'POST';
|
||||
$ua->timeout($self->cfg('timeout')) if $self->cfg('timeout');
|
||||
#print "TO: ",$ua->timeout(),"\n";
|
||||
$ua->agent("JMX::Jmx4Perl::Agent $VERSION");
|
||||
# $ua->env_proxy;
|
||||
my $proxy = $self->cfg('proxy');
|
||||
if ($proxy) {
|
||||
my $url = ref($proxy) eq "HASH" ? $proxy->{url} : $proxy;
|
||||
if (ref($url) eq "HASH") {
|
||||
for my $k (keys %$url) {
|
||||
$ua->proxy($k,$url->{$k});
|
||||
}
|
||||
} else {
|
||||
if ($self->cfg('url') =~ m|^(.*?)://|) {
|
||||
# Set proxy for URL scheme used
|
||||
$ua->proxy($1,$url);
|
||||
} else {
|
||||
$ua->proxy('http',$proxy);
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->{ua} = $ua;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $url = $agent->url()
|
||||
|
||||
Get the base URL for connecting to the agent. You cannot change the URL via this
|
||||
method, it is immutable for a given agent.
|
||||
|
||||
=cut
|
||||
|
||||
sub url {
|
||||
my $self = shift;
|
||||
return $self->cfg('url');
|
||||
}
|
||||
|
||||
=item $resp = $agent->request($request)
|
||||
|
||||
Implementation of the JMX request as specified in L<JMX::Jmx4Perl>. It uses a
|
||||
L<HTTP::Request> sent via an L<LWP::UserAgent> for posting a JSON representation
|
||||
of the request. This method shouldn't be called directly but via
|
||||
L<JMX::Jmx4Perl>->request().
|
||||
|
||||
=cut
|
||||
|
||||
sub request {
|
||||
my $self = shift;
|
||||
my @jmx_requests = $self->cfg('target') ? $self->_update_targets(@_) : @_;
|
||||
my $ua = $self->{ua};
|
||||
my $http_req = $self->_to_http_request(@jmx_requests);
|
||||
if ($self->{cfg}->{verbose}) {
|
||||
print $http_req->as_string;
|
||||
print "===========================================================\n";
|
||||
}
|
||||
#print Dumper($http_req);
|
||||
my $http_resp = $ua->request($http_req);
|
||||
my $json_resp = {};
|
||||
if ($self->{cfg}->{verbose}) {
|
||||
print $http_resp->as_string,"\n";
|
||||
print "===========================================================\n";
|
||||
}
|
||||
eval {
|
||||
$json_resp = from_json($http_resp->content());
|
||||
};
|
||||
my $json_error = $@;
|
||||
if ($http_resp->is_error) {
|
||||
return JMX::Jmx4Perl::Response->new
|
||||
(
|
||||
status => $http_resp->code,
|
||||
value => $json_error ? $http_resp->content : $json_resp,
|
||||
error => $json_error ? $self->_prepare_http_error_text($http_resp) :
|
||||
ref($json_resp) eq "ARRAY" ? join "\n", map { $_->{error} } grep { $_->{error} } @$json_resp : $json_resp->{error},
|
||||
stacktrace => ref($json_resp) eq "ARRAY" ? $self->_extract_stacktraces($json_resp) : $json_resp->{stacktrace},
|
||||
request => @jmx_requests == 1 ? $jmx_requests[0] : \@jmx_requests
|
||||
);
|
||||
} elsif ($json_error) {
|
||||
# If is not an HTTP-Error and deserialization fails, then we
|
||||
# probably got a wrong URL and get delivered some server side
|
||||
# document (with HTTP code 200)
|
||||
my $e = $json_error;
|
||||
$e =~ s/(.*)at .*?line.*$/$1/;
|
||||
return JMX::Jmx4Perl::Response->new
|
||||
(
|
||||
status => 400,
|
||||
error =>
|
||||
"Error while deserializing JSON answer (Wrong URL ?)\n" . $e,
|
||||
value => $http_resp->content
|
||||
);
|
||||
}
|
||||
|
||||
my @responses = ($self->_from_http_response($json_resp,@jmx_requests));
|
||||
if (!wantarray && scalar(@responses) == 1) {
|
||||
return shift @responses;
|
||||
} else {
|
||||
return @responses;
|
||||
}
|
||||
}
|
||||
|
||||
=item $encrypted = $agent->encrypt($plain)
|
||||
|
||||
Encrypt a password which can be used in configuration files in order to
|
||||
obfuscate the clear text password.
|
||||
|
||||
=cut
|
||||
|
||||
sub encrypt {
|
||||
return "[[" . &JMX::Jmx4Perl::Agent::UserAgent::encrypt(shift) . "]]";
|
||||
}
|
||||
|
||||
|
||||
# Create an HTTP-Request for calling the server
|
||||
sub _to_http_request {
|
||||
my $self = shift;
|
||||
my @reqs = @_;
|
||||
if ($self->_use_GET_request(\@reqs)) {
|
||||
# Old, rest-style
|
||||
my $url = $self->request_url($reqs[0]);
|
||||
return HTTP::Request->new(GET => $url);
|
||||
} else {
|
||||
my $url = $self->cfg('url') || croak "No URL provided";
|
||||
$url .= "/" unless $url =~ m|/$|;
|
||||
my $request = HTTP::Request->new(POST => $url);
|
||||
my $content = to_json(@reqs > 1 ? \@reqs : $reqs[0], { convert_blessed => 1 });
|
||||
#print Dumper($reqs[0],$content);
|
||||
$request->content($content);
|
||||
return $request;
|
||||
}
|
||||
}
|
||||
|
||||
sub _use_GET_request {
|
||||
my $self = shift;
|
||||
my $reqs = shift;
|
||||
if (@$reqs == 1) {
|
||||
my $req = $reqs->[0];
|
||||
# For proxy configs and explicite set POST request, get can not be
|
||||
# used
|
||||
return 0 if defined($req->get("target"));
|
||||
#print Dumper($req);
|
||||
for my $r ($req->method,$self->cfg('method')) {
|
||||
return lc($r) eq "get" if defined($r);
|
||||
}
|
||||
# GET by default
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
# Create one or more response objects for a given request
|
||||
sub _from_http_response {
|
||||
my $self = shift;
|
||||
my $json_resp = shift;
|
||||
my @reqs = @_;
|
||||
if (ref($json_resp) eq "HASH") {
|
||||
return JMX::Jmx4Perl::Response->new(%{$json_resp},request => $reqs[0]);
|
||||
} elsif (ref($json_resp) eq "ARRAY") {
|
||||
die "Internal: Number of request and responses doesn't match (",scalar(@reqs)," vs. ",scalar(@$json_resp)
|
||||
unless scalar(@reqs) == scalar(@$json_resp);
|
||||
|
||||
my @ret = ();
|
||||
for (my $i=0;$i<@reqs;$i++) {
|
||||
die "Internal: Not a hash --> ",$json_resp->[$i] unless ref($json_resp->[$i]) eq "HASH";
|
||||
my $response = JMX::Jmx4Perl::Response->new(%{$json_resp->[$i]},request => $reqs[$i]);
|
||||
push @ret,$response;
|
||||
}
|
||||
return @ret;
|
||||
} else {
|
||||
die "Internal: Not a hash nor an array but ",ref($json_resp) ? ref($json_resp) : $json_resp;
|
||||
}
|
||||
}
|
||||
|
||||
# Update targets if not set in request.
|
||||
sub _update_targets {
|
||||
my $self = shift;
|
||||
my @requests = @_;
|
||||
my $target = $self->_clone_target;
|
||||
for my $req (@requests) {
|
||||
$req->{target} = $target unless exists($req->{target});
|
||||
# A request with existing but undefined target removes
|
||||
# any default
|
||||
delete $req->{target} unless defined($req->{target});
|
||||
}
|
||||
return @requests;
|
||||
}
|
||||
|
||||
sub _clone_target {
|
||||
my $self = shift;
|
||||
die "Internal: No target set" unless $self->cfg('target');
|
||||
my $target = { %{$self->cfg('target')} };
|
||||
if ($target->{env}) {
|
||||
$target->{env} = { %{$target->{env}}};
|
||||
}
|
||||
return $target;
|
||||
}
|
||||
|
||||
=item $url = $agent->request_url($request)
|
||||
|
||||
Generate the URL for accessing the java agent based on a given request.
|
||||
|
||||
=cut
|
||||
|
||||
sub request_url {
|
||||
my $self = shift;
|
||||
my $request = shift;
|
||||
my $url = $self->cfg('url') || croak "No base url given in configuration";
|
||||
$url .= "/" unless $url =~ m|/$|;
|
||||
|
||||
my $type = $request->get("type");
|
||||
my $req = $type . "/";
|
||||
$req .= $self->_escape($request->get("mbean"));
|
||||
|
||||
if ($type eq READ) {
|
||||
$req .= "/" . $self->_escape($request->get("attribute"));
|
||||
$req .= $self->_extract_path($request->get("path"));
|
||||
} elsif ($type eq WRITE) {
|
||||
$req .= "/" . $self->_escape($request->get("attribute"));
|
||||
$req .= "/" . $self->_escape($self->_null_escape($request->get("value")));
|
||||
$req .= $self->_extract_path($request->get("path"));
|
||||
} elsif ($type eq LIST) {
|
||||
$req .= $self->_extract_path($request->get("path"));
|
||||
} elsif ($type eq EXEC) {
|
||||
$req .= "/" . $self->_escape($request->get("operation"));
|
||||
for my $arg (@{$request->get("arguments")}) {
|
||||
# Array refs are sticked together via ","
|
||||
my $a = ref($arg) eq "ARRAY" ? join ",",@{$arg} : $arg;
|
||||
$req .= "/" . $self->_escape($self->_null_escape($a));
|
||||
}
|
||||
} elsif ($type eq SEARCH) {
|
||||
# Nothing further to append.
|
||||
}
|
||||
# Squeeze multiple slashes
|
||||
$req =~ s|((?:!/)?/)/*|$1|g;
|
||||
#print "R: $req\n";
|
||||
|
||||
if ($req =~ $INVALID_PATH_CHARS || $request->{use_query}) {
|
||||
$req = "?p=$req";
|
||||
}
|
||||
my @params;
|
||||
for my $k (@PARAMS) {
|
||||
push @params, $k . "=" . $request->get($k)
|
||||
if $request->get($k);
|
||||
}
|
||||
$req .= ($req =~ /\?/ ? "&" : "?") . join("&",@params) if @params;
|
||||
return $url . $req;
|
||||
}
|
||||
|
||||
|
||||
# =============================================================================
|
||||
|
||||
|
||||
# Return an (optional) path which must already be escaped
|
||||
sub _extract_path {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
return $path ? "/" . $path : "";
|
||||
}
|
||||
|
||||
|
||||
# Escaping is simple:
|
||||
# ! --> !!
|
||||
# / --> !/
|
||||
# It is not done by backslashes '\' since often they get magically get
|
||||
# translated into / when part of an URL
|
||||
sub _escape {
|
||||
my $self = shift;
|
||||
my $input = shift;
|
||||
if ($self->cfg('legacy-escape')) {
|
||||
# Pre 1.0 escaping:
|
||||
$input =~ s|(/+)|"/" . ('-' x length($1)) . "/"|eg;
|
||||
$input =~ s|^/-|/^|; # The first slash needs to be escaped (first)
|
||||
$input =~ s|-/$|+/|; # as well as last slash. They need a special
|
||||
# escape, because two subsequent slashes get
|
||||
# squeezed to one on the server side
|
||||
|
||||
} else {
|
||||
# Simpler escaping since 1.0:
|
||||
$input =~ s/!/!!/g;
|
||||
$input =~ s/\//!\//g;
|
||||
}
|
||||
|
||||
return URI::Escape::uri_escape_utf8($input,"^A-Za-z0-9\-_.!~*'()/"); # Added "/" to
|
||||
# default
|
||||
# set. See L<URI>
|
||||
}
|
||||
|
||||
# Escape empty and undef values so that they can be detangled
|
||||
# on the server side
|
||||
sub _null_escape {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (!defined($value)) {
|
||||
return "[null]";
|
||||
} elsif (! length($value)) {
|
||||
return "\"\"";
|
||||
} else {
|
||||
return $value;
|
||||
}
|
||||
}
|
||||
|
||||
# Prepare some readable error text
|
||||
sub _prepare_http_error_text {
|
||||
my $self = shift;
|
||||
my $http_resp = shift;
|
||||
my $content = $http_resp->content;
|
||||
my $error = "Error while fetching ".$http_resp->request->uri." :\n\n" . $http_resp->status_line . "\n";
|
||||
chomp $content;
|
||||
if ($content && $content ne $http_resp->status_line) {
|
||||
my $error .= "=" x length($http_resp->status_line) . "\n\n";
|
||||
my $short = substr($content,0,600);
|
||||
$error .= $short . (length($short) < length($content) ? "\n\n... [truncated] ...\n\n" : "") . "\n"
|
||||
}
|
||||
return $error;
|
||||
}
|
||||
|
||||
# Extract all stacktraces stored in the given array ref of json responses
|
||||
sub _extract_stacktraces {
|
||||
my $self = shift;
|
||||
my $json_resp = shift;
|
||||
my @ret = ();
|
||||
for my $j (@$json_resp) {
|
||||
push @ret,$j->{stacktrace} if $j->{stacktrace};
|
||||
}
|
||||
return @ret ? (scalar(@ret) == 1 ? $ret[0] : \@ret) : undef;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
# ===================================================================
|
||||
# Specialized UserAgent for passing in credentials:
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
322
lib/JMX/Jmx4Perl/Agent/Jolokia/ArtifactHandler.pm
Normal file
322
lib/JMX/Jmx4Perl/Agent/Jolokia/ArtifactHandler.pm
Normal file
@@ -0,0 +1,322 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::ArtifactHandler;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::ArtifactHandler - Handler for extracting and manipulating
|
||||
Jolokia artifacts
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is responsible for mangaging a singe JAR or WAR Archive. It
|
||||
requires L<Archive::Zip> for proper operation.
|
||||
|
||||
I.e. this module can
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
Extract jolokia-access.xml and web.xml from WAR/JAR archives
|
||||
|
||||
=item *
|
||||
|
||||
Check for the esistance of jolokia-access.xml
|
||||
|
||||
=item *
|
||||
|
||||
Update web.xml for WAR files
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
use Data::Dumper;
|
||||
use strict;
|
||||
|
||||
use vars qw($HAS_ARCHIVE_ZIP $GLOBAL_ERROR);
|
||||
|
||||
BEGIN {
|
||||
$HAS_ARCHIVE_ZIP = eval "require Archive::Zip; Archive::Zip->import(qw(:ERROR_CODES)); 1";
|
||||
if ($HAS_ARCHIVE_ZIP) {
|
||||
Archive::Zip::setErrorHandler( sub {
|
||||
$GLOBAL_ERROR = join " ",@_;
|
||||
chomp $GLOBAL_ERROR;
|
||||
} );
|
||||
}
|
||||
}
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $handler = JMX::Jmx4Perl::Agent::Jolokia::ArtifactHandler->new(...)
|
||||
|
||||
Create a new handler with the following options:
|
||||
|
||||
file => $file : Path to archive to handle
|
||||
logger => $logger : Logger to use
|
||||
meta => $meta : Jolokia-Meta handler to extract the type of an archive
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %args = @_;
|
||||
my $file = $args{file};
|
||||
my $self = { file => $file, logger => $args{logger}, meta => $args{meta}};
|
||||
bless $self,(ref($class) || $class);
|
||||
$self->_fatal("No Archive::Zip found. Please install it for handling Jolokia archives.") unless $HAS_ARCHIVE_ZIP;
|
||||
$self->_fatal("No file given") unless $file;
|
||||
$self->_fatal("No such file $file") unless -e $file;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
=item $info = $handler->info()
|
||||
|
||||
Extract information about an archive. Return value is a has with the following
|
||||
keys:
|
||||
|
||||
"version" Agent's version
|
||||
"type" Agent type (war, osgi, osgi-bundle, mule, jdk6)
|
||||
"artifactId" Maven artifact id
|
||||
"groupId" Maven group Id
|
||||
|
||||
=cut
|
||||
|
||||
sub info {
|
||||
my $self = shift;
|
||||
my $file = $self->{file};
|
||||
my $jar = $self->_read_archive();
|
||||
my @props = $jar->membersMatching('META-INF/maven/org.jolokia/.*?/pom.properties');
|
||||
$self->_fatal("Cannot extract pom.properties from $file") unless @props;
|
||||
for my $prop (@props) {
|
||||
my ($content,$status) = $prop->contents;
|
||||
$self->_fatal("Cannot extract pom.properties: ",$GLOBAL_ERROR) unless $status eq AZ_OK();
|
||||
my $ret = {};
|
||||
for my $l (split /\n/,$content) {
|
||||
next if $l =~ /^\s*#/;
|
||||
my ($k,$v) = split /=/,$l,2;
|
||||
$ret->{$k} = $v;
|
||||
}
|
||||
$self->_fatal("$file is not a Jolokia archive") unless $ret->{groupId} eq "org.jolokia" ;
|
||||
my $type;
|
||||
if ($self->{meta}->initialized()) {
|
||||
$type = $self->{meta}->extract_type($ret->{artifactId});
|
||||
} else {
|
||||
$type = $self->_detect_type_by_heuristic($ret->{artifactId});
|
||||
}
|
||||
if ($type) {
|
||||
$ret->{type} = $type;
|
||||
return $ret;
|
||||
}
|
||||
}
|
||||
return {};
|
||||
}
|
||||
|
||||
=item $handler->add_policy($policy)
|
||||
|
||||
Add or update the policy given as string to this archive. Dependening on
|
||||
whether it is a WAR or another agent, it is put into the proper place
|
||||
|
||||
For "war" agents, this is F<WEB-INF/classes/jolokia-access.xml>, for all others
|
||||
it is F</jolokia-access.xml>
|
||||
|
||||
=cut
|
||||
|
||||
sub add_policy {
|
||||
my $self = shift;
|
||||
my $policy = shift;
|
||||
my $file = $self->{file};
|
||||
$self->_fatal("No such file $policy") unless -e $policy;
|
||||
|
||||
my $jar = $self->_read_archive();
|
||||
my $path = $self->_policy_path;
|
||||
|
||||
my $existing = $jar->removeMember($path);
|
||||
my $res = $jar->addFile($policy,$path);
|
||||
$self->_fatal("Cannot add $policy to $file as ",$path,": ",$GLOBAL_ERROR) unless $res;
|
||||
my $status = $jar->overwrite();
|
||||
$self->_fatal("Cannot write $file: ",$GLOBAL_ERROR) unless $status eq AZ_OK();
|
||||
$self->_info($existing ? "Replacing existing policy " : "Adding policy ","[em]",$path,"[/em]",$existing ? " in " : " to ","[em]",$file,"[/em]");
|
||||
}
|
||||
|
||||
=item $handler->remove_policy()
|
||||
|
||||
Remove a policy file (no-op, when no policy is present)
|
||||
|
||||
=cut
|
||||
|
||||
sub remove_policy {
|
||||
my $self = shift;
|
||||
|
||||
my $file = $self->{file};
|
||||
|
||||
my $jar = $self->_read_archive();
|
||||
my $path = $self->_policy_path;
|
||||
|
||||
my $existing = $jar->removeMember($path);
|
||||
if ($existing) {
|
||||
my $status = $jar->overwrite();
|
||||
$self->_fatal("Cannot write $file: ",$GLOBAL_ERROR) unless $status eq AZ_OK();
|
||||
$self->_info("Removing policy","[em]",$path,"[/em]"," in ","[em]",$file,"[/em]");
|
||||
} else {
|
||||
$self->_info("No policy found, leaving ","[em]",$file,"[/em]"," untouched.");
|
||||
}
|
||||
}
|
||||
|
||||
=item $handler->has_policy()
|
||||
|
||||
Returns true (i.e. the path to the policy file) if a policy file is contained,
|
||||
C<undef> otherwise.
|
||||
|
||||
=cut
|
||||
|
||||
sub has_policy {
|
||||
my $self = shift;
|
||||
|
||||
my $jar = $self->_read_archive();
|
||||
my $path = $self->_policy_path;
|
||||
return $jar->memberNamed($path) ? $path : undef;
|
||||
}
|
||||
|
||||
=item $handler->get_policy()
|
||||
|
||||
Get the policy file as string or C<undef> if no policy is contained.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_policy {
|
||||
my $self = shift;
|
||||
|
||||
my $jar = $self->_read_archive();
|
||||
my $path = $self->_policy_path;
|
||||
return $jar->contents($path);
|
||||
}
|
||||
|
||||
=item $handler->extract_webxml()
|
||||
|
||||
Extract F<web.xml> from WAR agents, for other types, a fatal error is
|
||||
raised. Return value is a string containing the web.xml.
|
||||
|
||||
=cut
|
||||
|
||||
sub extract_webxml {
|
||||
my $self = shift;
|
||||
my $type = $self->type;
|
||||
$self->_fatal("web.xml can only be read from 'war' archives (not '",$type,"')") unless $type eq "war";
|
||||
|
||||
my $jar = $self->_read_archive();
|
||||
return $jar->contents("WEB-INF/web.xml");
|
||||
}
|
||||
|
||||
=item $handler->update_webxml($webxml)
|
||||
|
||||
Update F<web.xml> in WAR agents, for other types, a fatal error is
|
||||
raised. Return value is a string containing the web.xml. C<$webxml> is the
|
||||
descriptor as a string.
|
||||
|
||||
=cut
|
||||
|
||||
sub update_webxml {
|
||||
my $self = shift;
|
||||
my $webxml = shift;
|
||||
my $type = $self->type;
|
||||
$self->_fatal("web.xml can only be updated in 'war' archives (not '",$type,"')") unless $type eq "war";
|
||||
|
||||
my $jar = $self->_read_archive();
|
||||
$jar->removeMember("WEB-INF/web.xml");
|
||||
my $res = $jar->addString($webxml,"WEB-INF/web.xml");
|
||||
$self->_fatal("Cannot update WEB-INF/web.xml: ",$GLOBAL_ERROR) unless $res;
|
||||
my $status = $jar->overwrite();
|
||||
$self->_fatal("Cannot write ",$self->{file},": ",$GLOBAL_ERROR) unless $status eq AZ_OK();
|
||||
$self->_info("Updated ","[em]","web.xml","[/em]"," for ",$self->{file});
|
||||
}
|
||||
|
||||
=item $handler->type()
|
||||
|
||||
Return the agent's type, which is one of "war", "osgi", "osgi-bundle", "mule"
|
||||
or "jdk6"
|
||||
|
||||
=cut
|
||||
|
||||
sub type {
|
||||
my $self = shift;
|
||||
my $info = $self->info;
|
||||
return $info->{type};
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
# ========================================================================
|
||||
|
||||
sub _detect_type_by_heuristic {
|
||||
my $self = shift;
|
||||
my $artifact_id = shift;
|
||||
return {
|
||||
"jolokia-osgi" => "osgi",
|
||||
"jolokia-mule" => "mule",
|
||||
"jolokia-osgi-bundle" => "osgi-bundle",
|
||||
"jolokia-jvm-jdk6" => "jdk6",
|
||||
"jolokia-jvm" => "jvm",
|
||||
"jolokia-war" => "war"
|
||||
}->{$artifact_id};
|
||||
}
|
||||
|
||||
sub _read_archive {
|
||||
my $self = shift;
|
||||
my $file = $self->{file};
|
||||
my $jar = new Archive::Zip();
|
||||
my $status = $jar->read($file);
|
||||
$self->_fatal("Cannot read content of $file: ",$GLOBAL_ERROR) unless $status eq AZ_OK();
|
||||
return $jar;
|
||||
}
|
||||
|
||||
|
||||
sub _policy_path {
|
||||
my $self = shift;
|
||||
return ($self->type eq "war" ? "WEB-INF/classes/" : "") . "jolokia-access.xml";
|
||||
}
|
||||
|
||||
|
||||
sub _fatal {
|
||||
my $self = shift;
|
||||
$self->{logger}->error(@_);
|
||||
die "\n";
|
||||
}
|
||||
|
||||
sub _info {
|
||||
my $self = shift;
|
||||
$self->{logger}->info(@_);
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
150
lib/JMX/Jmx4Perl/Agent/Jolokia/DownloadAgent.pm
Normal file
150
lib/JMX/Jmx4Perl/Agent/Jolokia/DownloadAgent.pm
Normal file
@@ -0,0 +1,150 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::DownloadAgent;
|
||||
use base qw(LWP::UserAgent);
|
||||
use Data::Dumper;
|
||||
use vars qw($HAS_PROGRESS_BAR $HAS_TERM_READKEY);
|
||||
use strict;
|
||||
|
||||
BEGIN {
|
||||
$HAS_PROGRESS_BAR = eval "require Term::ProgressBar; 1";
|
||||
$HAS_TERM_READKEY = eval "require Term::ReadKey; 1";
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::DownloadAgent - Specialized L<LWP::UserAgent>
|
||||
adding some bells and whistles for downloading agents and other stuff.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
User agent for Jolokia artifact downloading. It decorates a regular User Agent
|
||||
with a download bar and allows for proxy handling and authentication. For a
|
||||
progress bar, the optional module L<Term::ProgressBar> must be installed.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $ua = JMX::Jmx4Perl::Agent::Jolokia::DownloadAgent->new(%args)
|
||||
|
||||
Create a new user agent, a subclass fro L<LWP::UserAgent>
|
||||
|
||||
Options:
|
||||
|
||||
"http_proxy" HTTP Proxy to use
|
||||
"https_proxy" HTTPS Proxy to use
|
||||
"quiet" If true, dont show progressbar
|
||||
"proxy_user" Proxy user for proxy authentication
|
||||
"proxy_password" Proxy password for proxy authentication
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %cfg = ref($_[0]) eq "HASH" ? %{$_[0]} : @_;
|
||||
my $self = LWP::UserAgent::new($class,%cfg);
|
||||
bless $self,(ref($class) || $class);
|
||||
|
||||
# Proxy setting
|
||||
$self->env_proxy;
|
||||
$self->proxy("http",$cfg{http_proxy}) if $cfg{http_proxy};
|
||||
$self->proxy("https",$cfg{https_proxy}) if $cfg{https_proxy};
|
||||
$self->agent("Jolokia Download Agent/" . $JMX::Jmx4Perl::VERSION);
|
||||
$self->{show_progress} = !$cfg{quiet};
|
||||
return $self;
|
||||
}
|
||||
|
||||
# Overwriting progress in order to show a progressbar or not
|
||||
sub progress {
|
||||
my($self, $status, $m) = @_;
|
||||
return unless $self->{show_progress};
|
||||
# Use default progress bar if no progress is given
|
||||
unless ($HAS_PROGRESS_BAR) {
|
||||
$self->SUPER::progress($status,$m);
|
||||
return;
|
||||
}
|
||||
if ($status eq "begin") {
|
||||
$self->{progress_bar} = undef;
|
||||
} elsif ($status eq "end") {
|
||||
my $progress = delete $self->{progress_bar};
|
||||
my $next = delete $self->{progress_next};
|
||||
$progress->update(1) if defined($next) && 1 >= $next;
|
||||
} elsif ($status eq "tick") {
|
||||
# Unknown length (todo: probably better switch to the default behaviour
|
||||
# in SUPER::progress())
|
||||
my $progress = $self->_progress_bar($m->filename,undef);
|
||||
$progress->update();
|
||||
} else {
|
||||
# Status contains percentage
|
||||
my $progress = $self->_progress_bar($m->filename,1);
|
||||
|
||||
# print $status," ",$HAS_PROGRESS_BAR,"\n";
|
||||
$self->{progress_next} = $progress->update($status)
|
||||
if $status >= $self->{progress_next};
|
||||
}
|
||||
}
|
||||
|
||||
sub _progress_bar {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $count = shift;
|
||||
my $progress = $self->{progress_bar};
|
||||
unless ($progress) {
|
||||
no strict;
|
||||
local (%SIG);
|
||||
$progress = new Term::ProgressBar({
|
||||
name => " " . $name,
|
||||
count => $count,
|
||||
remove => 1,
|
||||
ETA => linear,
|
||||
!$HAS_TERM_READKEY ? (term_width => 120) : ()
|
||||
}
|
||||
);
|
||||
#$progress->minor(1);
|
||||
$progress->max_update_rate(1);
|
||||
$self->{progress_bar} = $progress;
|
||||
}
|
||||
return $progress;
|
||||
|
||||
}
|
||||
|
||||
|
||||
# Get an optional proxy user
|
||||
sub get_basic_credentials {
|
||||
my ($self, $realm, $uri, $isproxy) = @_;
|
||||
|
||||
if ($isproxy && $self->{proxy_user}) {
|
||||
return ($self->{proxy_user},$self->{proxy_password});
|
||||
} else {
|
||||
return (undef,undef);
|
||||
}
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
167
lib/JMX/Jmx4Perl/Agent/Jolokia/Logger.pm
Normal file
167
lib/JMX/Jmx4Perl/Agent/Jolokia/Logger.pm
Normal file
@@ -0,0 +1,167 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Logger;
|
||||
|
||||
use vars qw($HAS_COLOR);
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::Logger - Simple logging abstraction for the
|
||||
Jolokia agent manager
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Simple Logger used throughout 'jolokia' and its associated modules for
|
||||
output. It knows about coloring and a quiet mode, where no output is generated
|
||||
at all.
|
||||
|
||||
=cut
|
||||
|
||||
BEGIN {
|
||||
$HAS_COLOR = eval "require Term::ANSIColor; Term::ANSIColor->import(qw(:constants)); 1";
|
||||
}
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $logger = JMX::Jmx4Perl::Agent::Jolokia::Logger->new(quiet=>1,color=>1)
|
||||
|
||||
Creates a logger. Dependening on the options (C<quiet> and C<color>) output can
|
||||
be supressed completely or coloring can be used. Coloring only works, if the
|
||||
Module L<Term::ANSIColor> is available (which is checked during runtime).
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = ref($_[0]) eq "HASH" ? $_[0] : { @_ };
|
||||
|
||||
my $quiet = delete $self->{quiet};
|
||||
$HAS_COLOR &&= $self->{color};
|
||||
|
||||
# No-op logger
|
||||
return new JMX::Jmx4Perl::Agent::Jolokia::Logger::None
|
||||
if $quiet;
|
||||
|
||||
bless $self,(ref($class) || $class);
|
||||
}
|
||||
|
||||
=item $log->debug("....");
|
||||
|
||||
Debug output
|
||||
|
||||
=cut
|
||||
|
||||
sub debug {
|
||||
my $self = shift;
|
||||
if ($self->{debug}) {
|
||||
print "+ ",join("",@_),"\n";
|
||||
}
|
||||
}
|
||||
|
||||
=item $log->info("....","[em]","....","[/em]",...);
|
||||
|
||||
Info output. The tag "C<[em]>" can be used to higlight a portion of the
|
||||
output. The tag must be provided in an extra element in the given list.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub info {
|
||||
my $self = shift;
|
||||
my $text = $self->_resolve_color(@_);
|
||||
my ($cs,$ce) = $HAS_COLOR ? (DARK . CYAN,RESET) : ("","");
|
||||
print $cs . "*" . $ce . " " . $text . "\n";
|
||||
}
|
||||
|
||||
=item $log->warn(...)
|
||||
|
||||
Warning output (printed in yellow)
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub warn {
|
||||
my $self = shift;
|
||||
my $text = join "",@_;
|
||||
my ($cs,$ce) = $HAS_COLOR ? (YELLOW,RESET) : ("","");
|
||||
print $cs. "! " . $text . $ce ."\n";
|
||||
}
|
||||
|
||||
=item $log->warn(...)
|
||||
|
||||
Error output (printed in red)
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub error {
|
||||
my $self = shift;
|
||||
my $text = join "",@_;
|
||||
my ($cs,$ce) = $HAS_COLOR ? (RED,RESET) : ("","");
|
||||
print $cs . $text . $ce . "\n";
|
||||
}
|
||||
|
||||
sub _resolve_color {
|
||||
my $self = shift;
|
||||
return join "",map {
|
||||
if (lc($_) eq "[em]") {
|
||||
$HAS_COLOR ? GREEN : ""
|
||||
} elsif (lc($_) eq "[/em]") {
|
||||
$HAS_COLOR ? RESET : ""
|
||||
} else {
|
||||
$_
|
||||
}} @_;
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Logger::None;
|
||||
use base qw(JMX::Jmx4Perl::Agent::Jolokia::Logger);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::Logger::None - No-op logger
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
No-op logger used when quiet mode is switched on. Doesn't print
|
||||
out anything.
|
||||
|
||||
=cut
|
||||
|
||||
sub info { }
|
||||
sub warn { }
|
||||
sub error { }
|
||||
sub debug { }
|
||||
|
||||
|
||||
1;
|
||||
379
lib/JMX/Jmx4Perl/Agent/Jolokia/Meta.pm
Normal file
379
lib/JMX/Jmx4Perl/Agent/Jolokia/Meta.pm
Normal file
@@ -0,0 +1,379 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Meta;
|
||||
|
||||
use JMX::Jmx4Perl::Agent::Jolokia::DownloadAgent;
|
||||
use JMX::Jmx4Perl::Agent::Jolokia::Logger;
|
||||
use JMX::Jmx4Perl::Agent::Jolokia::Verifier;
|
||||
use JSON;
|
||||
use Data::Dumper;
|
||||
use base qw(LWP::UserAgent);
|
||||
use strict;
|
||||
|
||||
my $JOLOKIA_META_URL = "http://www.jolokia.org/jolokia.meta";
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::Meta - Fetches, caches and parses Meta data from
|
||||
www.jolokia.org
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is responsible for fetching meta data about available agents from
|
||||
Jolokia. It knows how to parse those meta data and caches it for subsequent
|
||||
usage in the local file system.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $meta = JMX::Jmx4Perl::Agent::Jolokia::Meta->new(....)
|
||||
|
||||
Create a new meta object which handles downloading of Jolokia meta information
|
||||
and caching this data.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = ref($_[0]) eq "HASH" ? $_[0] : { @_ };
|
||||
# Dummy logging if none is provided
|
||||
$self->{logger} = new JMX::Jmx4Perl::Agent::Jolokia::Logger::None unless $self->{logger};
|
||||
$self->{verifier} = new JMX::Jmx4Perl::Agent::Jolokia::Verifier(logger => $self->{logger},ua_config => $self->{ua_config});
|
||||
return bless $self,(ref($class) || $class);
|
||||
}
|
||||
|
||||
=item $meta->load($force)
|
||||
|
||||
Load the meta data from the server or retrieve it from the cache. The data is
|
||||
taken from the cache, if it is no older than $self->{cache_interval} seconds.
|
||||
If $force is given and true, the data is always fetched fresh from the server.
|
||||
|
||||
This method return $self so that it can be used for chaining. Any error or
|
||||
progress infos are given through to the C<log_handler> provided during
|
||||
construction time. This method will return C<undef> if the data can't be
|
||||
loaded.
|
||||
|
||||
=cut
|
||||
|
||||
sub load {
|
||||
my ($self,$force) = @_;
|
||||
$force = $self->{force_load} unless defined($force);
|
||||
my $meta_json;
|
||||
my $cached = undef;
|
||||
if (!$force) {
|
||||
$meta_json = $self->_from_cache;
|
||||
$cached = 1 if $meta_json;
|
||||
}
|
||||
$meta_json = $self->_load_from_server unless $meta_json; # Throws an error
|
||||
# if it can't be
|
||||
# loaded
|
||||
return undef unless $meta_json;
|
||||
$self->_to_cache($meta_json) unless $cached;
|
||||
$self->{_meta} = $meta_json;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $meta->initialized()
|
||||
|
||||
Returns C<true> if the meta data has been initialized, either by loading it or
|
||||
by using a cached data. If false the data can be loaded via L<load>
|
||||
|
||||
=cut
|
||||
|
||||
sub initialized {
|
||||
my $self = shift;
|
||||
return defined($self->{_meta});
|
||||
}
|
||||
|
||||
=item $value = $meta->get($key)
|
||||
|
||||
Get a value from the meta data.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
$self->_fatal("No yet loaded") unless $self->{_meta};
|
||||
return $self->{_meta}->{$key};
|
||||
}
|
||||
|
||||
|
||||
=item $jolokia_version = $meta->latest_matching_version($jmx4perl_version)
|
||||
|
||||
Get the latest matching Jolokia version for a given Jmx4Perl version
|
||||
|
||||
=cut
|
||||
|
||||
sub latest_matching_version {
|
||||
my $self = shift;
|
||||
my $jmx4perl_version = shift;
|
||||
# Iterate over all existing versions, starting from the newest one,
|
||||
# and return the first matching
|
||||
my $version_info = $self->get("versions");
|
||||
for my $v (sort { $self->compare_versions($b,$a) } grep { $_ !~ /-SNAPSHOT$/ } keys %$version_info) {
|
||||
my $range = $version_info->{$v}->{jmx4perl};
|
||||
if ($range) {
|
||||
my $match = $self->_check_version($jmx4perl_version,$range);
|
||||
#print "Match: $match for $range (j4p: $jmx4perl_version)\n";
|
||||
return $v if $match;
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Compare two version which can contain one, two or more digits. Returns <0,0 or
|
||||
# >0 if the first version is smaller, equal or larger than the second version.
|
||||
# It doesn't take into account snapshot
|
||||
sub compare_versions {
|
||||
my $self = shift;
|
||||
my @first = _split_version(shift);
|
||||
my @second = _split_version(shift);
|
||||
my $len = $#first < $#second ? $#first : $#second;
|
||||
for my $i (0 ... $len) {
|
||||
next if $first[$i] == $second[$i];
|
||||
return $first[$i] - $second[$i];
|
||||
}
|
||||
return $#first - $#second;
|
||||
}
|
||||
|
||||
sub _split_version {
|
||||
my $v = shift;
|
||||
$v =~ s/-.*$//;
|
||||
return split /\./,$v;
|
||||
}
|
||||
|
||||
sub _check_version {
|
||||
my $self = shift;
|
||||
my $jmx4perl_version = shift;
|
||||
my $range = shift;
|
||||
|
||||
my ($l,$l_v,$u_v,$u) = ($1,$2,$3,$4) if $range =~ /^\s*([\[\(])\s*([\d\.]+)\s*,\s*([\d\.]+)\s*([\)\]])\s*$/;
|
||||
if ($l_v) {
|
||||
my $cond = "\$a " . ($l eq "[" ? ">=" : ">"). $l_v . " && \$a" . ($u eq "]" ? "<=" : "<") . $u_v;
|
||||
my $a = $jmx4perl_version;
|
||||
return eval $cond;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item $meta->versions_compatible($jmx4perl_version,$jolokia_version)
|
||||
|
||||
Check, whether the Jolokia and Jmx4Perl versions are compaptible, i.e.
|
||||
whether Jmx4Perl with the given version can interoperate with the given
|
||||
Jolokia version
|
||||
|
||||
=cut
|
||||
|
||||
sub versions_compatible {
|
||||
my $self = shift;
|
||||
my $jmx4perl_version = shift;
|
||||
my $jolokia_version = shift;
|
||||
|
||||
my $version_info = $self->get("versions");
|
||||
my $range = $version_info->{$jolokia_version}->{jmx4perl};
|
||||
if ($range) {
|
||||
return $self->_check_version($jmx4perl_version,$range);
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
=item $type = $meta->extract_type($artifact_name)
|
||||
|
||||
Extract the type for a given artifactId
|
||||
|
||||
=cut
|
||||
|
||||
sub extract_type {
|
||||
my $self = shift;
|
||||
my $artifact = shift;
|
||||
my $mapping = $self->get("mapping");
|
||||
for my $k (keys %$mapping) {
|
||||
return $k if $mapping->{$k}->[0] eq $artifact;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item $meta->template_url($template_name,$version)
|
||||
|
||||
Download a template with the given name. The download URL is looked up
|
||||
in the meta data. If a version is given, the template for this specific
|
||||
version is returned (if present, if not the default template is returned).
|
||||
If no version is given, the default template is returned. The downloaded
|
||||
template is verified as any other downloaded artifact.
|
||||
|
||||
The template is returned as a string.
|
||||
|
||||
=cut
|
||||
|
||||
sub template_url {
|
||||
my $self = shift;
|
||||
my $template = shift;
|
||||
my $version = shift;
|
||||
|
||||
my $url;
|
||||
if ($version) {
|
||||
my $version_info = $self->get("versions");
|
||||
my $v_data = $version_info->{$version};
|
||||
$self->_fatal("Cannot load template $template for version $version since $version is unknown")
|
||||
unless $v_data;
|
||||
my $templs = $v_data->{templates};
|
||||
if ($templs) {
|
||||
$url = $templs->{$template};
|
||||
}
|
||||
}
|
||||
unless ($url) {
|
||||
my $templs = $self->get("templates");
|
||||
$self->_fatal("No templates defined in jolokia.meta") unless $templs;
|
||||
$url = $templs->{$template};
|
||||
}
|
||||
return $url;
|
||||
}
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
# ===================================================================================
|
||||
|
||||
# Fetch from cache, but only if the cache file is older than $cache_interval
|
||||
# seconds back in time
|
||||
sub _from_cache {
|
||||
my $self = shift;
|
||||
my $cache_interval = $self->{cache_interval} || 12 * 60 * 60; # 12h by default
|
||||
my $cache_file = $self->{cache_file} || $ENV{HOME} . "/.jolokia_meta";
|
||||
my $mtime = (stat($cache_file))[9];
|
||||
if ($mtime && $mtime >= time - $cache_interval) {
|
||||
if (!open(F,$cache_file)) {
|
||||
$self->_error("Cannot open $cache_file: $!");
|
||||
return undef;
|
||||
}
|
||||
my $ret = join "",<F>;
|
||||
close F;
|
||||
$self->_debug("Loaded Jolokia meta data from cache");
|
||||
return from_json($ret,{utf8 => 1});
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# Store to cache
|
||||
sub _to_cache {
|
||||
my $self = shift;
|
||||
my $meta = shift;
|
||||
my $cache_file = $self->{cache_file} || $ENV{HOME} . "/.jolokia_meta";
|
||||
if (!open(F,">$cache_file")) {
|
||||
$self->_error("Cannot save $cache_file: $!");
|
||||
return;
|
||||
}
|
||||
print F to_json($meta,{utf8 => 1,pretty => 1});
|
||||
close F;
|
||||
}
|
||||
|
||||
# Load from server
|
||||
sub _load_from_server {
|
||||
my $self = shift;
|
||||
|
||||
# Create sample meta-data
|
||||
return $self->_example_meta if ($ENV{USE_SAMPLE_JOLOKIA_META});
|
||||
|
||||
# Load with HTTP-Client, hardcoded for now
|
||||
$self->_info("Loading Jolokia meta data from $JOLOKIA_META_URL");
|
||||
|
||||
my $ua = new JMX::Jmx4Perl::Agent::Jolokia::DownloadAgent($self->{ua_config});
|
||||
my $response = $ua->get($JOLOKIA_META_URL);
|
||||
if ($response->is_success) {
|
||||
my $content = $response->decoded_content; # or whatever
|
||||
$self->{verifier}->verify(ua_config => $self->{ua_config}, logger => $self->{logger},
|
||||
url => $JOLOKIA_META_URL, data => $content);
|
||||
return from_json($content, {utf8 => 1});
|
||||
}
|
||||
else {
|
||||
# Log an error, but do not exit ...
|
||||
$self->{logger}->error("Cannot load Jolokia Meta-Data from $JOLOKIA_META_URL: " . $response->status_line);
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# Do something with errors and info messages
|
||||
|
||||
sub _debug {
|
||||
shift->{logger}->debug(@_);
|
||||
}
|
||||
|
||||
sub _error {
|
||||
my $self = shift;
|
||||
$self->{logger}->error(@_);
|
||||
}
|
||||
|
||||
sub _fatal {
|
||||
my $self = shift;
|
||||
$self->{logger}->error(@_);
|
||||
die "\n";
|
||||
}
|
||||
|
||||
sub _info {
|
||||
my $self = shift;
|
||||
$self->{logger}->info(@_);
|
||||
}
|
||||
|
||||
# Sample meta data, also used for creating site meta data.
|
||||
sub _example_meta {
|
||||
return {
|
||||
repositories => [
|
||||
"http://labs.consol.de/maven/repository"
|
||||
],
|
||||
'snapshots-repositories' => [
|
||||
"http://labs.consol.de/maven/snapshots-repository"
|
||||
],
|
||||
versions => {
|
||||
"0.90-SNAPSHOT" => { jmx4perl => "[0.90,1.0)" },
|
||||
"0.83" => { jmx4perl => "[0.73,1.0)" },
|
||||
"0.82" => { jmx4perl => "[0.73,1.0)" } ,
|
||||
"0.81" => { jmx4perl => "[0.73,1.0)" } ,
|
||||
},
|
||||
mapping => {
|
||||
"war" => [ "jolokia-war", "jolokia-war-%v.war", "jolokia.war" ],
|
||||
"osgi" => [ "jolokia-osgi", "jolokia-osgi-%v.jar", "jolokia.jar" ],
|
||||
"osgi-bundle" => [ "jolokia-osgi-bundle", "jolokia-osgi-bundle-%v.jar", "jolokia-bundle.jar" ],
|
||||
"mule" => [ "jolokia-mule", "jolokia-mule-%v.jar", "jolokia-mule.jar" ],
|
||||
"jdk6" => [ "jolokia-jvm-jdk6", "jolokia-jvm-jdk6-%v-agent.jar", "jolokia.jar" ]
|
||||
},
|
||||
templates => {
|
||||
"jolokia-access.xml" => "http://www.jolokia.org/templates/jolokia-access.xml"
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
162
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier.pm
Normal file
162
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier.pm
Normal file
@@ -0,0 +1,162 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Verifier;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Verifier - Handler for various verifiers which picks
|
||||
the most secure one first.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Entry module for verification of downloaded artifacts. Depending on modules
|
||||
installed, various validation mechanisms are tried in decreasing order fo
|
||||
vialibility:
|
||||
|
||||
=over
|
||||
|
||||
=item L<Crypt::OpenPGP>
|
||||
|
||||
The strongest validation is provided by PGP signatures with which Jolokia
|
||||
artifact is signed. The verifier uses L<Crypt::OpenPGP> for verifying PGP
|
||||
signatures.
|
||||
|
||||
=item L<Digest::SHA1>
|
||||
|
||||
If OpenPGP is not available or when no signature is provided from the Jolokia
|
||||
site (unlikely), a simple SHA1 checksum is fetched and compared to the artifact
|
||||
downloaded. This is not secure, but guarantees some degree of consistency.
|
||||
|
||||
=item L<Digest::MD5>
|
||||
|
||||
As last resort, when this module is availabl, a MD5 checksum is calculated and
|
||||
compared to the checksum also downloaded from www.jolokia.org.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
use Data::Dumper;
|
||||
use vars qw(@VERIFIERS @WARNINGS);
|
||||
use strict;
|
||||
|
||||
# Pick the verifier, which is the most reliable
|
||||
|
||||
BEGIN {
|
||||
@VERIFIERS = ();
|
||||
@WARNINGS = ();
|
||||
|
||||
my $create = sub {
|
||||
my $module = shift;
|
||||
eval "require $module";
|
||||
die $@ if $@;
|
||||
my $verifier;
|
||||
eval "\$verifier = new $module()";
|
||||
die $@ if $@;
|
||||
return $verifier;
|
||||
};
|
||||
|
||||
my $prefix = "JMX::Jmx4Perl::Agent::Jolokia::Verifier::";
|
||||
if (`gpg --version` =~ /GnuPG/m) {
|
||||
push @VERIFIERS,$create->($prefix . "GnuPGVerifier");
|
||||
} else {
|
||||
push @WARNINGS,"No signature verification available. Please install GnupPG.";
|
||||
}
|
||||
|
||||
# Disabled support for OpenPGP since it doesn't support the digest
|
||||
# algorithm used for signging the jolokia artefacts
|
||||
# } elsif (eval "requireCrypt::OpenPGP; 1") {
|
||||
# push @VERIFIERS,$create->($prefix . "OpenPGPVerifier");
|
||||
|
||||
push @VERIFIERS,$create->($prefix . "SHA1Verifier") if eval "require Digest::SHA1; 1";
|
||||
push @VERIFIERS,$create->($prefix . "MD5Verifier") if eval "require Digest::MD5; 1";
|
||||
}
|
||||
|
||||
=item $verifier = JMX::Jmx4Perl::Agent::Jolokia::Verifier->new(%args)
|
||||
|
||||
Creates a new verifier. It takes an expanded hash als argument, where the
|
||||
following keys are respected:
|
||||
|
||||
"ua_config" UserAgent configuration used for accessing
|
||||
remote signatures/checksums
|
||||
"logger" Logger
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {@_};
|
||||
bless $self,(ref($class) || $class);
|
||||
}
|
||||
|
||||
=item $verifier->verify(url => $url,path => $file)
|
||||
|
||||
=item $verifier->verify(url => $url,data => $data)
|
||||
|
||||
Verifies the given file (C<path>) or scalar data (C<data>) by trying various
|
||||
validators in turn. Technically, each validator is asked for an extension
|
||||
(e.g. ".asc" for a PGP signature), which is appended to URL and this URL is
|
||||
tried for downloading the signature/checksum. If found, the content of the
|
||||
signature/checksum is passed to specific verifier along with the data/file to
|
||||
validate. A verifier will die, if validation fails, so one should put this in
|
||||
an eval if required. If validation passes, the method returns silently.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub verify {
|
||||
my $self = shift;
|
||||
my %args = @_;
|
||||
my $url = $args{url};
|
||||
|
||||
my $ua = new JMX::Jmx4Perl::Agent::Jolokia::DownloadAgent($self->{ua_config});
|
||||
my $log = $self->{logger};
|
||||
$log->warn($_) for @WARNINGS;
|
||||
for my $verifier (@VERIFIERS) {
|
||||
my $ext = $verifier->extension;
|
||||
if ($ext) {
|
||||
my $response = $ua->get($url . $ext);
|
||||
if ($response->is_success) {
|
||||
my $content = $response->decoded_content;
|
||||
$verifier->verify(%args,signature => $content,logger => $log);
|
||||
return;
|
||||
} else {
|
||||
$log->warn($verifier->name . ": Couldn't load $url$ext");
|
||||
}
|
||||
}
|
||||
}
|
||||
$log->warn("No suitable validation mechanism found with $url");
|
||||
}
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
89
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/ChecksumVerifier.pm
Normal file
89
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/ChecksumVerifier.pm
Normal file
@@ -0,0 +1,89 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Verifier::ChecksumVerifier;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::Verifier::ChecksumVerifier - Verifies a
|
||||
checksum for a downloaded artifact.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This verifier provides the base for simple checksum checking. It needs to be
|
||||
subclassed to provide the proper extension (e.g. ".sha1") and creating of a
|
||||
digester.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
bless $self,(ref($class) || $class);
|
||||
}
|
||||
|
||||
sub extension {
|
||||
die "abstract";
|
||||
}
|
||||
|
||||
sub name {
|
||||
die "abstract";
|
||||
}
|
||||
|
||||
sub create_digester {
|
||||
die "abstract";
|
||||
}
|
||||
|
||||
sub verify {
|
||||
my $self = shift;
|
||||
my %args = @_;
|
||||
my $logger = $args{logger};
|
||||
my $sig = $args{signature};
|
||||
chomp $sig;
|
||||
$sig =~ s/^([^\s]+).*$/$1/;
|
||||
my $digester = $self->create_digester;
|
||||
my $file = $args{path};
|
||||
if ($file) {
|
||||
open (my $fh, "<", $file) || ($logger->error("Cannot open $file for ",$self->name," check: $!") && die "\n");
|
||||
$digester->addfile($fh);
|
||||
close $fh;
|
||||
} else {
|
||||
my $data = $args{data};
|
||||
$digester->add($data);
|
||||
}
|
||||
my $sig_calc = $digester->hexdigest;
|
||||
if (lc($sig) eq lc($sig_calc)) {
|
||||
$logger->info("Passed ",$self->name," check (" . $sig_calc . ")",($file ? " for file $file" : ""));
|
||||
} else {
|
||||
$logger->error("Failed ",$self->name," check. Got: " . $sig_calc . ", Expected: " . $sig);
|
||||
die "\n";
|
||||
}
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
170
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/GnuPGVerifier.pm
Normal file
170
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/GnuPGVerifier.pm
Normal file
@@ -0,0 +1,170 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Verifier::GnuPGVerifier;
|
||||
|
||||
use JMX::Jmx4Perl::Agent::Jolokia::Verifier::PGPKey;
|
||||
use Module::Find;
|
||||
use Data::Dumper;
|
||||
use File::Temp qw/tempfile/;
|
||||
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::Verifier::GnuPGVerifier - Verifies PGP
|
||||
signature with a natively installed GnuPG (with gpg found in the path)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This verifier uses a natively installed GPG for validating a PGP signature
|
||||
obtained from the download site. It's similar to
|
||||
L<JMX::Jmx4Perl::Agent::Jolokia::Verifier::OpenPGPVerifier> except that it will
|
||||
use a locally installed GnuPG installation. Please note, that it will import
|
||||
the public key used for signature verification into the local keystore.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
($self->{gpg},$self->{version}) = &_gpg_version();
|
||||
bless $self,(ref($class) || $class);
|
||||
}
|
||||
|
||||
sub extension {
|
||||
return ".asc";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "GnuPG";
|
||||
}
|
||||
|
||||
sub verify {
|
||||
my $self = shift;
|
||||
my %args = @_;
|
||||
|
||||
my $log = $args{logger};
|
||||
my $gpg = $self->{gpg};
|
||||
|
||||
die "Neither 'path' nor 'data' given for specifying the file/data to verify"
|
||||
unless $args{path} || $args{data};
|
||||
|
||||
my $signature_path = $self->_store_tempfile($args{signature});
|
||||
my $path = $args{path} ? $args{path} : $self->_store_tempfile($args{data});
|
||||
my @cmd = (
|
||||
$gpg,
|
||||
qw(--verify --batch --no-tty -q --logger-fd=1),
|
||||
);
|
||||
eval {
|
||||
push @cmd, $signature_path,$path;
|
||||
# Unset language for proper parsing of the output independent
|
||||
# of the locale
|
||||
local $ENV{LANG} = undef;
|
||||
my $cmd = join ' ', @cmd;
|
||||
my $output = `$cmd`;
|
||||
if ($output =~ /public\s*key/i) {
|
||||
# Import key and retry
|
||||
$self->_import_key(\%args);
|
||||
$output = `$cmd`;
|
||||
}
|
||||
|
||||
$self->_verify_gpg_output($?,$output,\%args);
|
||||
};
|
||||
|
||||
# Always cleanup
|
||||
my $error = $@;
|
||||
unlink $signature_path;
|
||||
unlink $path unless $args{path};
|
||||
die $error if $error;
|
||||
|
||||
}
|
||||
|
||||
sub _verify_gpg_output {
|
||||
my $self = shift;
|
||||
my $code = shift;
|
||||
my $output = shift;
|
||||
my $args = shift;
|
||||
my $log = $args->{logger};
|
||||
my $key = $1 if $output =~ /\s+([\dA-F]{8})/;
|
||||
# print $output,"\n";
|
||||
if ($code) {
|
||||
$log->error("Invalid signature",$args->{path} ? " for " . $args->{path} : "",$key ? " (key: $key)" : "");
|
||||
die "\n";
|
||||
} else {
|
||||
$log->info("Good PGP signature" . ($key ? " ($key)" : ""));
|
||||
}
|
||||
}
|
||||
|
||||
sub _import_key {
|
||||
my $self = shift;
|
||||
my $args = shift;
|
||||
|
||||
my $gpg = $self->{gpg};
|
||||
my $log = $args->{logger};
|
||||
my $key_path = $self->_store_tempfile($JMX::Jmx4Perl::Agent::Jolokia::Verifier::PGPKey::KEY);
|
||||
|
||||
my @cmd = ($gpg,qw(--import --verbose --batch --no-tty --logger-fd=1),$key_path);
|
||||
my $cmd = join ' ', @cmd;
|
||||
my $output = `$cmd 2>&1`;
|
||||
if ($?) {
|
||||
$log->error("Cannot add public PGP used for verification to local keystore: $output");
|
||||
die "\n";
|
||||
} else {
|
||||
#$log->info($output);
|
||||
my $info = $1 if $output =~ /([\dA-F]{8}.*import.*)$/mi;
|
||||
$log->info($info ? $info : "Added jmx4perl key");
|
||||
}
|
||||
unlink $key_path;
|
||||
}
|
||||
|
||||
|
||||
sub _gpg_version {
|
||||
my $gpg = "gpg2";
|
||||
my $out = `gpg2 --version`;
|
||||
if ($?) {
|
||||
$out = `gpg --version`;
|
||||
$gpg = "gpg";
|
||||
if ($?) {
|
||||
die "Cannot find gpg or gpg2: $out\n";
|
||||
}
|
||||
}
|
||||
$out =~ /GnuPG.*?(\S+)\s*$/m;
|
||||
return ($gpg,$1);
|
||||
}
|
||||
|
||||
sub _store_tempfile {
|
||||
my $self = shift;
|
||||
my $sig = shift || die "No data given to store in temp file";
|
||||
my ($fh,$path) = tempfile();
|
||||
print $fh $sig;
|
||||
close $fh;
|
||||
return $path;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
60
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/MD5Verifier.pm
Normal file
60
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/MD5Verifier.pm
Normal file
@@ -0,0 +1,60 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Verifier::MD5Verifier;
|
||||
|
||||
use Digest::MD5;
|
||||
use JMX::Jmx4Perl::Agent::Jolokia::Verifier::ChecksumVerifier;
|
||||
use base qw(JMX::Jmx4Perl::Agent::Jolokia::Verifier::ChecksumVerifier);
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::Verifier::MD5Verifier - Verifies a
|
||||
MD5 checksum
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Verifies against a MD5 checksum for an artifact. The MD5 sum needs to be
|
||||
available parallel to the download artifact with a ".md5" extension.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub extension {
|
||||
return ".md5";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "MD5";
|
||||
}
|
||||
|
||||
sub create_digester {
|
||||
return new Digest::MD5();
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
114
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/OpenPGPVerifier.pm
Normal file
114
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/OpenPGPVerifier.pm
Normal file
@@ -0,0 +1,114 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Verifier::OpenPGPVerifier;
|
||||
|
||||
use JMX::Jmx4Perl::Agent::Jolokia::Verifier::PGPKey;
|
||||
use Crypt::OpenPGP::KeyRing;
|
||||
use Crypt::OpenPGP;
|
||||
use Module::Find;
|
||||
use Data::Dumper;
|
||||
use Cwd 'abs_path';
|
||||
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::Verifier::OpenPGPVerifier - Verifies PGP
|
||||
signature with L<Crypt::OpenPGP>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This verifier uses L<Crypt::OpenPGP> for validating a PGP signature obtained
|
||||
from the download site. Ie. each URL used for download should have (and does
|
||||
have) and associated signature ending with F<.asc>. This verifier typically
|
||||
quite robust, however installing L<Crypt::OpenPGP> is a bit clumsy, so you
|
||||
might omit this one.
|
||||
|
||||
=head1 IMPORTANT
|
||||
|
||||
It is not used currently since the new agents has been signed with 'digest
|
||||
algortihm 10' which is not supported by OpenPGP. Use a native GnuPG instead
|
||||
(i.e. a 'gpg' which is in the path)
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
$self->{keyring} = $JMX::Jmx4Perl::Agent::Jolokia::Verifier::PGPKey::KEY;
|
||||
bless $self,(ref($class) || $class);
|
||||
}
|
||||
|
||||
sub extension {
|
||||
return ".asc";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "OpenPGP";
|
||||
}
|
||||
|
||||
sub verify {
|
||||
my $self = shift;
|
||||
my %args = @_;
|
||||
|
||||
my $kr = new Crypt::OpenPGP::KeyRing(Data => $self->{keyring});
|
||||
my $pgp = new Crypt::OpenPGP(PubRing => $kr);
|
||||
my $path = $args{path};
|
||||
my $log = $args{logger};
|
||||
my $validate;
|
||||
if ($path) {
|
||||
$validate = $pgp->verify(Files => [abs_path($args{path})],Signature => $args{signature});
|
||||
} else {
|
||||
$validate = $pgp->verify(Data => $args{data},Signature => $args{signature});
|
||||
}
|
||||
if ($validate) {
|
||||
my $key;
|
||||
if ($validate != 1) {
|
||||
my $kb = $kr->find_keyblock_by_uid($validate);
|
||||
if ($kb) {
|
||||
eval {
|
||||
# Non-document method
|
||||
$key = $kb->key->key_id_hex;
|
||||
$key = substr $key,8,8 if length($key) > 8;
|
||||
};
|
||||
}
|
||||
}
|
||||
$log->info("Good PGP signature",
|
||||
($validate != 1 ? (", signed by ",$validate) : ""),
|
||||
($key ? " ($key)" :""));
|
||||
return 1;
|
||||
} elsif ($validate == 0) {
|
||||
$log->error("Invalid signature",$path ? " for $path" : "",": " . $pgp->errstr);
|
||||
die "\n";
|
||||
} else {
|
||||
$log->error("Error occured while verifying signature: ",$pgp->errstr);
|
||||
die "\n";
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
35
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/PGPKey.pm
Normal file
35
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/PGPKey.pm
Normal file
@@ -0,0 +1,35 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Verifier::PGPKey;
|
||||
|
||||
use strict;
|
||||
use vars qw($KEY);
|
||||
|
||||
# Public key for verifying downloaded artifacts
|
||||
|
||||
$KEY = <<EOT;
|
||||
-----BEGIN PGP PUBLIC KEY BLOCK-----
|
||||
Version: GnuPG v1.4.10 (GNU/Linux)
|
||||
|
||||
mQCNAzpoBEMAAAEEAMdDw9V+zMCjJI6Icjv+Z+s5mepNJ+tH848PVOfZohfDoEZx
|
||||
pthbKW+U0EgFVtV8EE9iWDQOh68U3BvEaOvk+99YoahRRACuII1Y+Q445UaNV/Tn
|
||||
hCGmofWITYY8Tbz6dcYnWsWMQ5XByM4aMwucM8pUARomkrrM9kKyJpPvEBFlAAUR
|
||||
tCFSb2xhbmQgSHVzcyA8cm9sYW5kQGpteDRwZXJsLm9yZz6JAJUDBRNNcVaiQrIm
|
||||
k+8QEWUBARSrA/9gp7YhV7kh47WWtzC25aaW/WS2FwiBqKsOIJ5z8kkrEDOqz3iU
|
||||
TEzyHMgngwR7dNqZAM2xZlt6uTW1VuhraOFp27V0UVpQg/l1XaHF9JNVPvsbGmFG
|
||||
MIu/2gQrkhI9/Amyy5Zi3w2mbwISQ897QVY0O98/BlcymFpl5hrx4qbSdbQdUm9s
|
||||
YW5kIEh1c3MgPHJvbGFuZEBjcGFuLm9yZz6JAJUDBRA6aATCQrImk+8QEWUBAbKN
|
||||
A/9IEGDcSG7bB7ZW2oDzny++6nhpsHzRlSIwcXJA20W73bu/So8+v6fl4CiBEtZW
|
||||
KN6qCwqpreK6i8DHx+bGMkm8+uucO3G5vqi9FIF1yJt8ioLPyhPNktRGCCdSxbqG
|
||||
uYlOaDFwa9J9ebcqPe3mS0/374ixaArqpQPB+S/OU3nuXbQeUm9sYW5kIEh1c3Mg
|
||||
PHJvbGFuZEBjb25zb2wuZGU+iQCVAwUQOmgEQ0KyJpPvEBFlAQHI+AP9FbP3x5vs
|
||||
moXO95yV3PHhw0FOo9Szpd4kgIoXGMRVGC5gFKyX7dSU8jwi5PnSQRmTg8jQUUBj
|
||||
kVYi29nKHsOwp9J7oTbHlC02heaghjW5zTxxRv6lgmh3+cIsAimbi/fr3pRovRCT
|
||||
MS75CQJTAQAXz4+ALBxU3sG71kEx1mVwEIS0IFJvbGFuZCBIdXNzIDxyb2xhbmRA
|
||||
am9sb2tpYS5vcmc+iQCVAwUTTXFWgUKyJpPvEBFlAQHGcwP/UNWFVPiV+o3qWVfY
|
||||
+g9EiJoN43YN6QI3VasZ6Gjda3ZCJ6aLQXL9UorcTQBSIpCOKvEElG5Sw+dH0IPW
|
||||
jmrzWK1s9lnU2Qkx88QY5O489p+Z98SqbDGqW7DEIkYutYVou0nV7/SVyulMUNGe
|
||||
vqmY3GlfyqrXMXL+lu6IRpCfHcw=
|
||||
=HxAM
|
||||
-----END PGP PUBLIC KEY BLOCK-----
|
||||
EOT
|
||||
58
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/SHA1Verifier.pm
Normal file
58
lib/JMX/Jmx4Perl/Agent/Jolokia/Verifier/SHA1Verifier.pm
Normal file
@@ -0,0 +1,58 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::Verifier::SHA1Verifier;
|
||||
|
||||
use Digest::SHA1;
|
||||
use JMX::Jmx4Perl::Agent::Jolokia::Verifier::ChecksumVerifier;
|
||||
use base qw(JMX::Jmx4Perl::Agent::Jolokia::Verifier::ChecksumVerifier);
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::Verifier::SHA1Verifier - Verifies a
|
||||
SHA1 checksum
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Verifies against a SHA1 checksum for an artifact. The SHA1 sum needs to be
|
||||
available parallel to the download artifact with a ".sha1" extension.
|
||||
|
||||
=cut
|
||||
|
||||
sub extension {
|
||||
return ".sha1";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "SHA1";
|
||||
}
|
||||
|
||||
sub create_digester {
|
||||
return new Digest::SHA1();
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
452
lib/JMX/Jmx4Perl/Agent/Jolokia/WebXmlHandler.pm
Normal file
452
lib/JMX/Jmx4Perl/Agent/Jolokia/WebXmlHandler.pm
Normal file
@@ -0,0 +1,452 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::Agent::Jolokia::WebXmlHandler;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::Jolokia::WebXmlHandler - Handler for web.xml
|
||||
transformation
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is repsonsible for various manipulations on a F<web.xml> descriptor
|
||||
as found in JEE WAR archives. It uses L<XML::LibXML> for the dirty work, and
|
||||
L<XML::Tidy> to clean up after the manipulation. The later module is optional,
|
||||
but recommended.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
use Data::Dumper;
|
||||
use vars qw($HAS_LIBXML $HAS_XML_TWIG);
|
||||
use strict;
|
||||
|
||||
# Trigger for <login-config>
|
||||
my $REALM = "Jolokia";
|
||||
|
||||
# Class used as proxy dispatcher
|
||||
my $JSR_160_PROXY_CLASS = "org.jolokia.jsr160.Jsr160RequestDispatcher";
|
||||
|
||||
BEGIN {
|
||||
$HAS_LIBXML = eval "require XML::LibXML; use XML::LibXML::XPathContext; 1";
|
||||
$HAS_XML_TWIG = eval "require XML::Twig; 1";
|
||||
}
|
||||
|
||||
=item $handler = JMX::Jmx4Perl::Agent::Jolokia::WebXmlHandler->new(%args)
|
||||
|
||||
Creates a new handler. The following arguments can be used:
|
||||
|
||||
"logger" Logger to use
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %args = @_;
|
||||
my $self = {logger => $args{logger}};
|
||||
bless $self,(ref($class) || $class);
|
||||
|
||||
$self->_fatal("No XML::LibXML found. Please install it to allow changes and queries on web.xml") unless $HAS_LIBXML;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $handler->add_security($webxml,{ role => $role })
|
||||
|
||||
Add a security constraint to the given web.xml. This triggers on the realm
|
||||
"Jolokia" on the loging-config and the URL-Pattern "/*" for the security
|
||||
mapping. Any previous sections are removed and replaced.
|
||||
|
||||
C<$role> is the role to insert.
|
||||
|
||||
This method returns the updated web.xml as a string.
|
||||
|
||||
=cut
|
||||
|
||||
sub add_security {
|
||||
my $self = shift;
|
||||
my $webxml = shift;
|
||||
my $args = shift;
|
||||
|
||||
my $doc = XML::LibXML->load_xml(string => $webxml);
|
||||
|
||||
my $parent = $doc->getDocumentElement;
|
||||
$self->_remove_security_elements($doc);
|
||||
|
||||
$self->_create_login_config($doc,$parent);
|
||||
$self->_create_security_constraint($doc,$parent,$args->{role});
|
||||
$self->_create_security_role($doc,$parent,$args->{role});
|
||||
$self->_info("Added security mapping for role ","[em]",$args->{role},"[/em]");
|
||||
return $self->_cleanup_doc($doc);
|
||||
}
|
||||
|
||||
=item $handler->remove_security($webxml)
|
||||
|
||||
Remove login-config with Realm "Jolokia" and security constraint to
|
||||
"/*" along with the associated role definit. Return the updated web.xml
|
||||
as string.
|
||||
|
||||
=cut
|
||||
|
||||
sub remove_security {
|
||||
my $self = shift;
|
||||
my $webxml = shift;
|
||||
|
||||
my $doc = XML::LibXML->load_xml(string => $webxml);
|
||||
|
||||
$self->_remove_security_elements($doc);
|
||||
$self->_info("Removed security mapping");
|
||||
|
||||
return $self->_cleanup_doc($doc);
|
||||
}
|
||||
|
||||
=item $handler->add_jsr160_proxy($webxml)
|
||||
|
||||
Adds a JSR-160 proxy declaration which is contained as init-param of the
|
||||
servlet definition ("dispatcherClasses"). If the init-param is missing, a new
|
||||
is created otherwise an existing is updated. Does nothing, if the init-param
|
||||
"dispatcherClasses" already contains the JSR 160 dispacher.
|
||||
|
||||
Returns the updated web.xml as string.
|
||||
|
||||
=cut
|
||||
|
||||
sub add_jsr160_proxy {
|
||||
my $self = shift;
|
||||
my $webxml = shift;
|
||||
|
||||
my $doc = XML::LibXML->load_xml(string => $webxml);
|
||||
my @init_params = $self->_init_params($doc,"dispatcherClasses");
|
||||
if (!@init_params) {
|
||||
$self->_add_jsr160_proxy($doc);
|
||||
$self->_info("Added JSR-160 proxy");
|
||||
} elsif (@init_params == 1) {
|
||||
my $param = $init_params[0];
|
||||
my ($value,$classes) = $self->_extract_dispatcher_classes($init_params[0]);
|
||||
unless (grep { $_ eq $JSR_160_PROXY_CLASS } @$classes) {
|
||||
$self->_update_text($value,join(",",@$classes,$JSR_160_PROXY_CLASS));
|
||||
$self->_info("Added JSR-160 proxy");
|
||||
} else {
|
||||
$self->_info("JSR-160 proxy already active");
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
# Error
|
||||
$self->_fatal("More than one init-param 'dispatcherClasses' found");
|
||||
}
|
||||
|
||||
return $self->_cleanup_doc($doc);
|
||||
}
|
||||
|
||||
=item $handler->remove_jsr160_proxy($webxml)
|
||||
|
||||
Removes a JSR-160 proxy declaration which is contained as init-param of the
|
||||
servlet definition ("dispatcherClasses"). Does nothing, if the init-param
|
||||
"dispatcherClasses" already doese not contain the JSR 160 dispacher.
|
||||
|
||||
Returns the updated web.xml as string.
|
||||
|
||||
=cut
|
||||
|
||||
sub remove_jsr160_proxy {
|
||||
my $self = shift;
|
||||
my $webxml = shift;
|
||||
|
||||
my $doc = XML::LibXML->load_xml(string => $webxml);
|
||||
my @init_params = $self->_init_params($doc,"dispatcherClasses");
|
||||
if (!@init_params) {
|
||||
$self->info("No JSR-160 proxy active");
|
||||
return undef;
|
||||
} elsif (@init_params == 1) {
|
||||
my ($value,$classes) = $self->_extract_dispatcher_classes($init_params[0]);
|
||||
if (grep { $_ eq $JSR_160_PROXY_CLASS } @$classes) {
|
||||
$self->_update_text($value,join(",",grep { $_ ne $JSR_160_PROXY_CLASS } @$classes));
|
||||
$self->_info("Removed JSR-160 proxy");
|
||||
} else {
|
||||
$self->_info("No JSR-160 proxy active");
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$self->_fatal("More than one init-param 'dispatcherClasses' found");
|
||||
}
|
||||
|
||||
return $self->_cleanup_doc($doc);
|
||||
}
|
||||
|
||||
=item $handler->find($webxml,$xquery)
|
||||
|
||||
Find a single element with a given XQuery query. Croaks if more than one
|
||||
element is found. Returns either C<undef> (nothing found) or the matched
|
||||
node's text content.
|
||||
|
||||
=cut
|
||||
|
||||
sub find {
|
||||
my $self = shift;
|
||||
my $webxml = shift;
|
||||
my $query = shift;
|
||||
|
||||
my $doc = XML::LibXML->load_xml(string => $webxml);
|
||||
|
||||
my @nodes = $self->_find_nodes($doc,$query);
|
||||
$self->_fatal("More than one element found matching $query") if @nodes > 1;
|
||||
return @nodes == 0 ? undef : $nodes[0]->textContent;
|
||||
}
|
||||
|
||||
=item $handler->has_authentication($webxml)
|
||||
|
||||
Checks, whether authentication is switched on.
|
||||
|
||||
=cut
|
||||
|
||||
sub has_authentication {
|
||||
my $self = shift;
|
||||
my $webxml = shift;
|
||||
|
||||
$self->find
|
||||
($webxml,
|
||||
"//j2ee:security-constraint[j2ee:web-resource-collection/j2ee:url-pattern='/*']/j2ee:auth-constraint/j2ee:role-name");
|
||||
}
|
||||
|
||||
=item $handler->has_jsr160_proxy($webxml)
|
||||
|
||||
Checks, whether a JSR-160 proxy is configured.
|
||||
|
||||
=cut
|
||||
|
||||
sub has_jsr160_proxy {
|
||||
my $self = shift;
|
||||
my $webxml = shift;
|
||||
|
||||
my $doc = XML::LibXML->load_xml(string => $webxml);
|
||||
|
||||
my @init_params = $self->_init_params($doc,"dispatcherClasses");
|
||||
if (@init_params > 1) {
|
||||
$self->_fatal("More than one dispatcherClasses init-param found");
|
||||
} elsif (@init_params == 1) {
|
||||
my $param = $init_params[0];
|
||||
my ($value,$classes) = $self->_extract_dispatcher_classes($init_params[0]);
|
||||
return grep { $_ eq $JSR_160_PROXY_CLASS } @$classes;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
# ===============================================================================
|
||||
|
||||
sub _remove_security_elements {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
my $role = shift;
|
||||
|
||||
$self->_remove_login_config($doc);
|
||||
my $role = $self->_remove_security_constraint($doc);
|
||||
$self->_remove_security_role($doc,$role);
|
||||
}
|
||||
|
||||
sub _create_login_config {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
my $parent = shift;
|
||||
my $l = _e($doc,$parent,"login-config");
|
||||
_e($doc,$l,"auth-method","BASIC");
|
||||
_e($doc,$l,"realm-name",$REALM);
|
||||
}
|
||||
|
||||
sub _create_security_constraint {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
my $parent = shift;
|
||||
my $role = shift;
|
||||
|
||||
my $s = _e($doc,$parent,"security-constraint");
|
||||
my $w = _e($doc,$s,"web-resource-collection");
|
||||
_e($doc,$w,"web-resource-name","Jolokia-Agent Access");
|
||||
_e($doc,$w,"url-pattern","/*");
|
||||
my $a = _e($doc,$s,"auth-constraint");
|
||||
_e($doc,$a,"role-name",$role);
|
||||
}
|
||||
|
||||
sub _create_security_role {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
my $parent = shift;
|
||||
my $role = shift;
|
||||
|
||||
my $s = _e($doc,$parent,"security-role");
|
||||
_e($doc,$s,"role-name",$role);
|
||||
}
|
||||
|
||||
sub _remove_security_constraint {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
|
||||
my @s = $doc->getElementsByTagName("security-constraint");
|
||||
for my $s (@s) {
|
||||
my @r = $s->getElementsByTagName("role-name");
|
||||
my $role;
|
||||
for my $r (@r) {
|
||||
$role = $r->textContent;
|
||||
}
|
||||
my @u = $s->getElementsByTagName("url-pattern");
|
||||
for my $u (@u) {
|
||||
if ($u->textContent eq "/*") {
|
||||
$s->parentNode->removeChild($s);
|
||||
return $role;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _remove_login_config {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
|
||||
my @l = $doc->getElementsByTagName("realm-name");
|
||||
for my $l (@l) {
|
||||
if ($l->textContent eq $REALM) {
|
||||
my $toRemove = $l->parentNode;
|
||||
$toRemove->parentNode->removeChild($toRemove);
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _remove_security_role {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
my $role = shift;
|
||||
|
||||
my @s = $doc->getElementsByTagName("security-role");
|
||||
for my $s (@s) {
|
||||
my @r = $s->getElementsByTagName("role-name");
|
||||
for my $r (@r) {
|
||||
if ($r->textContent eq $role) {
|
||||
$s->parentNode->removeChild($s);
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _init_params {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
my $param_name = shift;
|
||||
|
||||
return $self->_find_nodes
|
||||
($doc,
|
||||
"/j2ee:web-app/j2ee:servlet[j2ee:servlet-name='jolokia-agent']/j2ee:init-param[j2ee:param-name='$param_name']");
|
||||
}
|
||||
|
||||
sub _extract_dispatcher_classes {
|
||||
my $self = shift;
|
||||
my $param = shift;
|
||||
|
||||
my @values = $self->_find_nodes($param,"j2ee:param-value");
|
||||
$self->_fatal("No or more than one param-value found") if (!@values || @values > 1);
|
||||
my $value = $values[0];
|
||||
my $content = $value->textContent();
|
||||
my @classes = split /\s*,\s*/,$content;
|
||||
return ($value,\@classes);
|
||||
}
|
||||
|
||||
sub _update_text {
|
||||
my $self = shift;
|
||||
my $el = shift;
|
||||
my $value = shift;
|
||||
|
||||
my $parent = $el->parentNode;
|
||||
$parent->removeChild($el);
|
||||
$parent->appendTextChild($el->nodeName,$value);
|
||||
}
|
||||
|
||||
sub _add_jsr160_proxy {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
my @init_params = $self->_find_nodes
|
||||
($doc,
|
||||
"/j2ee:web-app/j2ee:servlet[j2ee:servlet-name='jolokia-agent']/j2ee:init-param");
|
||||
my $first = $init_params[0] || $self->_fatal("No init-params found");
|
||||
my $new_init = $doc->createElement("init-param");
|
||||
_e($doc,$new_init,"param-name","dispatcherClasses");
|
||||
_e($doc,$new_init,"param-value",$JSR_160_PROXY_CLASS);
|
||||
$first->parentNode->insertBefore($new_init,$first);
|
||||
}
|
||||
|
||||
sub _find_nodes {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
my $query = shift;
|
||||
|
||||
my $xpc = XML::LibXML::XPathContext->new;
|
||||
$xpc->registerNs('j2ee', 'http://java.sun.com/xml/ns/j2ee');
|
||||
return $xpc->findnodes($query,$doc);
|
||||
}
|
||||
|
||||
sub _e {
|
||||
my $doc = shift;
|
||||
my $parent = shift;
|
||||
my $e = $doc->createElement(shift);
|
||||
my $c = shift;
|
||||
if ($c) {
|
||||
$e->appendChild($doc->createTextNode($c));
|
||||
}
|
||||
$parent->appendChild($e);
|
||||
return $e;
|
||||
}
|
||||
|
||||
sub _cleanup_doc {
|
||||
my $self = shift;
|
||||
my $doc = shift;
|
||||
if ($HAS_XML_TWIG) {
|
||||
my $ret = XML::Twig->nparse_pp($doc->toString)->toString(1);
|
||||
#print $ret;
|
||||
return $ret;
|
||||
} else {
|
||||
return $doc->toString(1);
|
||||
}
|
||||
}
|
||||
|
||||
sub _fatal {
|
||||
my $self = shift;
|
||||
$self->{logger}->error(@_);
|
||||
die "\n";
|
||||
}
|
||||
|
||||
sub _info {
|
||||
my $self = shift;
|
||||
$self->{logger}->info(@_);
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
167
lib/JMX/Jmx4Perl/Agent/UserAgent.pm
Normal file
167
lib/JMX/Jmx4Perl/Agent/UserAgent.pm
Normal file
@@ -0,0 +1,167 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
# Helper package in order to provide credentials
|
||||
# in the request
|
||||
package JMX::Jmx4Perl::Agent::UserAgent;
|
||||
use base qw(LWP::UserAgent);
|
||||
|
||||
use Sys::SigAction;
|
||||
|
||||
use vars qw($HAS_BLOWFISH_PP $BF);
|
||||
use strict;
|
||||
|
||||
BEGIN {
|
||||
$HAS_BLOWFISH_PP = eval "require Crypt::Blowfish_PP; 1";
|
||||
if ($HAS_BLOWFISH_PP) {
|
||||
$BF = new Crypt::Blowfish_PP(pack("C10",0x16,0x51,0xAE,0x13,0xF2,0xFA,0x11,0x20,0x6E,0x6A));
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Agent::UserAgent - Specialized L<LWP::UserAgent> adding
|
||||
authentication support
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Simple subclass implementing an own C<get_basic_credentials> method for support
|
||||
of basic and proxy authentication. This is an internal class used by
|
||||
L<JMX::Jmx4Perl::Agent>.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
# Constructor setting the proper SSL options (if possible)
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my @opts = @_ || ();
|
||||
if (LWP::UserAgent->VERSION >= 6.00) {
|
||||
# We don't verify Hostnames by default, since the information we are
|
||||
# sending is typically not critical. Also, we don't have yet a way to
|
||||
# configure a keystore, so this is the only chance for now. Ask me to add
|
||||
# host certificate verification if wanted. It disabled only for LWP >= 6.00
|
||||
push @opts,(ssl_opts => { verify_hostname => 0 });
|
||||
};
|
||||
return $class->SUPER::new(@opts);
|
||||
}
|
||||
|
||||
# Request using a more robust timeout See
|
||||
# http://stackoverflow.com/questions/73308/true-timeout-on-lwpuseragent-request-method
|
||||
# for details.
|
||||
sub request {
|
||||
my $self = shift;
|
||||
my $req = shift;
|
||||
|
||||
# Get whatever timeout is set for LWP and use that to
|
||||
# enforce a maximum timeout per request.
|
||||
use Sys::SigAction qw(timeout_call);
|
||||
our $res = undef;
|
||||
if (timeout_call($self->timeout(), sub { $res = $self->SUPER::request($req); })) {
|
||||
# 408 == HTTP timeout
|
||||
my $ret = HTTP::Response->new(408,"Got timeout in " . $self->timeout() . "s ");
|
||||
$ret->request($req);
|
||||
return $ret;
|
||||
} else {
|
||||
return $res;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub jjagent_config {
|
||||
my $self = shift;
|
||||
$self->{jjagent_config} = shift;
|
||||
}
|
||||
|
||||
sub get_basic_credentials {
|
||||
my ($self, $realm, $uri, $isproxy) = @_;
|
||||
|
||||
my $cfg = $self->{jjagent_config} || {};
|
||||
my $user = $isproxy ? $self->proxy_cfg($cfg,"user") : $cfg->{user};
|
||||
my $password = $isproxy ? $self->proxy_cfg($cfg,"password") : $cfg->{password};
|
||||
if ($user && $password) {
|
||||
return ($user,$self->conditionally_decrypt($password));
|
||||
} else {
|
||||
return (undef,undef);
|
||||
}
|
||||
}
|
||||
|
||||
sub proxy_cfg {
|
||||
my ($self,$cfg,$what) = @_;
|
||||
my $proxy = $cfg->{proxy};
|
||||
if (ref($proxy) eq "HASH") {
|
||||
return $proxy->{$what};
|
||||
} else {
|
||||
return $cfg->{"proxy_" . $what};
|
||||
}
|
||||
}
|
||||
|
||||
sub conditionally_decrypt {
|
||||
my $self = shift;
|
||||
my $password = shift;
|
||||
if ($password =~ /^\[\[\s*(.*)\s*\]\]$/) {
|
||||
# It's a encrypted password, lets decrypt it here
|
||||
return decrypt($1);
|
||||
} else {
|
||||
return $password;
|
||||
}
|
||||
}
|
||||
|
||||
sub decrypt {
|
||||
my $encrypted = shift;
|
||||
die "No encryption available. Please install Crypt::Blowfish_PP" unless $HAS_BLOWFISH_PP;
|
||||
my $rest = $encrypted;
|
||||
my $ret = "";
|
||||
while (length($rest) > 0) {
|
||||
my $block = substr($rest,0,16);
|
||||
$rest = substr($rest,16);
|
||||
$ret .= $BF->decrypt(pack("H*",$block));
|
||||
}
|
||||
$ret =~ s/\s*$//;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub encrypt {
|
||||
my $plain = shift;
|
||||
die "No encryption available. Please install Crypt::Blowfish_PP" unless $HAS_BLOWFISH_PP;
|
||||
my $rest = $plain;
|
||||
my $ret = "";
|
||||
while (length($rest) > 0) {
|
||||
my $block = substr($rest,0,8);
|
||||
if (length($block) < 8) {
|
||||
$block .= " " x (8 - length($block));
|
||||
}
|
||||
$rest = substr($rest,8);
|
||||
$ret .= unpack("H*",$BF->encrypt($block));
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
__DATA__
|
||||
328
lib/JMX/Jmx4Perl/Alias.pm
Normal file
328
lib/JMX/Jmx4Perl/Alias.pm
Normal file
@@ -0,0 +1,328 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::Alias;
|
||||
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use JMX::Jmx4Perl::Alias::Object;
|
||||
use Carp;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Alias - JMX alias names for jmx4perl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Aliases are shortcuts for certain MBean attributes and
|
||||
operations. Additionally, aliasing provides a thin abstraction layer which
|
||||
allows to map common functionality with different naming schemes across
|
||||
different application servers. E.g you can access the heap memory usage of your
|
||||
application by using the alias C<MEMORY_HEAP_USED> regardless how the specific
|
||||
MBean and its attributes are named on the target application server. Specific
|
||||
L<JMX::Jmx4Perl::Product> take care about this mapping.
|
||||
|
||||
Alias are normally named hierachically, from the most general to the most
|
||||
specific, where the parts are separate by underscore
|
||||
(C<_>). I.e. C<OS_MEMORY_TOTAL_PHYSICAL> specifies the total physical memory
|
||||
installed on the machine.
|
||||
|
||||
If you C<use> this module, be aware that B<all> aliases are imported in your
|
||||
name space a subroutines (so that you an use them without a C<$>).
|
||||
|
||||
Most of the methods in C<JMX::Jmx4Perl> which allows for aliases can take an
|
||||
alias in two forms. Either as a constant import by using this module or as
|
||||
string. The string can be either the name of the alias itself or, as an
|
||||
alternative format, a lower cased variant where underscores are replaced by
|
||||
colons. E.g C<"MEMORY_HEAP_USED"> and C<"memory:heap:used"> are both valid
|
||||
alias names.
|
||||
|
||||
Each alias is an object of the package L<JMX::Jmx4Perl::Alias::Object> which
|
||||
provides some additional informations about the alias.
|
||||
|
||||
To print out all available aliases, sorted by name and with a short
|
||||
description, you can use the C<help> subroutine, e.g. like in
|
||||
|
||||
perl -MJMX::Jmx4Perl::Alias -e 'JMX::Jmx4Perl::Alias::help'
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
my %ALIAS_MAP =
|
||||
(attribute =>
|
||||
{
|
||||
# ========================================================================================================
|
||||
SERVER_VERSION => ["Version of application server"],
|
||||
SERVER_NAME => ["Name of server software"],
|
||||
SERVER_ADDRESS => [ "IP Address of server, numeric"],
|
||||
SERVER_HOSTNAME => [ "Hostname of server"],
|
||||
|
||||
|
||||
# ========================================================================================================
|
||||
# Standard Java VM Attributes
|
||||
# Memory
|
||||
MEMORY_HEAP => [ "Heap memory usage, multiple values", [ "java.lang:type=Memory", "HeapMemoryUsage" ]],
|
||||
MEMORY_HEAP_USED => [ "Used heap memory", [ "java.lang:type=Memory", "HeapMemoryUsage", "used" ]],
|
||||
MEMORY_HEAP_INIT => [ "Initially allocated heap memory", [ "java.lang:type=Memory", "HeapMemoryUsage", "init" ]],
|
||||
MEMORY_HEAP_COMITTED => [ "Committed heap memory. That's the memory currently available for this JVM", [ "java.lang:type=Memory", "HeapMemoryUsage", "committed" ]],
|
||||
MEMORY_HEAP_MAX => [ "Maximum available heap memory", [ "java.lang:type=Memory", "HeapMemoryUsage", "max" ]],
|
||||
|
||||
MEMORY_NONHEAP => [ "Non-Heap memory usage, multiple values", [ "java.lang:type=Memory", "NonHeapMemoryUsage" ]],
|
||||
MEMORY_NONHEAP_USED => [ "Used non-heap memory (like a 'method area')", [ "java.lang:type=Memory", "NonHeapMemoryUsage", "used" ]],
|
||||
MEMORY_NONHEAP_INIT => [ "Initially allocated non-heap memory", [ "java.lang:type=Memory", "NonHeapMemoryUsage", "init" ]],
|
||||
MEMORY_NONHEAP_COMITTED => [ "Committed non-heap memory", [ "java.lang:type=Memory", "NonHeapMemoryUsage", "committed" ]],
|
||||
MEMORY_NONHEAP_MAX => [ "Maximum available non-heap memory", [ "java.lang:type=Memory", "NonHeapMemoryUsage", "max" ]],
|
||||
|
||||
MEMORY_VERBOSE => [ "Switch on/off verbose messages concerning the garbage collector", ["java.lang:type=Memory", "Verbose"]],
|
||||
|
||||
# Class loading
|
||||
CL_LOADED => [ "Number of currently loaded classes", [ "java.lang:type=ClassLoading", "LoadedClassCount"]],
|
||||
CL_UNLOADED => [ "Number of unloaded classes", [ "java.lang:type=ClassLoading", "UnloadedClassCount"]],
|
||||
CL_TOTAL => [ "Number of classes loaded in total", [ "java.lang:type=ClassLoading", "TotalLoadedClassCount"]],
|
||||
|
||||
# Threads
|
||||
THREAD_COUNT => ["Active threads in the system", [ "java.lang:type=Threading", "ThreadCount"]],
|
||||
THREAD_COUNT_PEAK => ["Peak thread count", [ "java.lang:type=Threading", "PeakThreadCount"]],
|
||||
THREAD_COUNT_STARTED => ["Count of threads started since system start", [ "java.lang:type=Threading", "TotalStartedThreadCount"]],
|
||||
THREAD_COUNT_DAEMON => ["Count of threads marked as daemons in the system", [ "java.lang:type=Threading", "DaemonThreadCount"]],
|
||||
|
||||
# Operating System
|
||||
OS_MEMORY_PHYSICAL_FREE => ["The amount of free physical memory for the OS", [ "java.lang:type=OperatingSystem", "FreePhysicalMemorySize"]],
|
||||
OS_MEMORY_PHYSICAL_TOTAL => ["The amount of total physical memory for the OS", [ "java.lang:type=OperatingSystem", "TotalPhysicalMemorySize"]],
|
||||
OS_MEMORY_SWAP_FREE => ["The amount of free swap space for the OS", [ "java.lang:type=OperatingSystem", "FreeSwapSpaceSize"]],
|
||||
OS_MEMORY_SWAP_TOTAL => ["The amount of total swap memory available", [ "java.lang:type=OperatingSystem", "TotalSwapSpaceSize"]],
|
||||
OS_MEMORY_VIRTUAL => ["Size of virtual memory used by this process", [ "java.lang:type=OperatingSystem", "CommittedVirtualMemorySize"]],
|
||||
OS_FILE_DESC_OPEN => ["Number of open file descriptors", [ "java.lang:type=OperatingSystem", "OpenFileDescriptorCount"]],
|
||||
OS_FILE_DESC_MAX => ["Maximum number of open file descriptors", [ "java.lang:type=OperatingSystem", "MaxFileDescriptorCount"]],
|
||||
OS_CPU_TIME => ["The cpu time used by this process", [ "java.lang:type=OperatingSystem", "ProcessCpuTime"]],
|
||||
OS_INFO_PROCESSORS => ["Number of processors", [ "java.lang:type=OperatingSystem", "AvailableProcessors"]],
|
||||
OS_INFO_ARCH => ["Architecture", [ "java.lang:type=OperatingSystem", "Arch"]],
|
||||
OS_INFO_NAME => ["Operating system name", [ "java.lang:type=OperatingSystem", "Name"]],
|
||||
OS_INFO_VERSION => ["Operating system version", [ "java.lang:type=OperatingSystem", "Version"]],
|
||||
|
||||
# Runtime
|
||||
RUNTIME_SYSTEM_PROPERTIES => ["System properties", [ "java.lang:type=Runtime", "SystemProperties"]],
|
||||
RUNTIME_VM_VERSION => ["Version of JVM", [ "java.lang:type=Runtime", "VmVersion"]],
|
||||
RUNTIME_VM_NAME => ["Name of JVM", [ "java.lang:type=Runtime", "VmName"]],
|
||||
RUNTIME_VM_VENDOR => ["JVM Vendor", [ "java.lang:type=Runtime", "VmVendor"]],
|
||||
RUNTIME_ARGUMENTS => ["Arguments when starting the JVM", [ "java.lang:type=Runtime", "InputArguments"]],
|
||||
RUNTIME_UPTIME => ["Total uptime of JVM", [ "java.lang:type=Runtime", "Uptime"]],
|
||||
RUNTIME_STARTTIME => ["Time when starting the JVM", [ "java.lang:type=Runtime", "StartTime"]],
|
||||
RUNTIME_CLASSPATH => ["Classpath", [ "java.lang:type=Runtime", "ClassPath"]],
|
||||
RUNTIME_BOOTCLASSPATH => ["Bootclasspath", [ "java.lang:type=Runtime", "BootClassPath"]],
|
||||
RUNTIME_LIBRARY_PATH => ["The LD_LIBRARY_PATH", [ "java.lang:type=Runtime", "LibraryPath"]],
|
||||
RUNTIME_NAME => ["Name of the runtime", [ "java.lang:type=Runtime", "Name"]],
|
||||
|
||||
# Jmx4Perl
|
||||
JMX4PERL_HISTORY_SIZE => [ "Size of the history of all attributes and operations in bytes" , ["jolokia:type=Config","HistorySize"]],
|
||||
JMX4PERL_HISTORY_MAX_ENTRIES => [ "Maximum number of entries per attribute/operation possible" , ["jolokia:type=Config","HistoryMaxEntries"]],
|
||||
JMX4PERL_DEBUG => [ "Switch on/off debugging by setting this boolean" , ["jolokia:type=Config","Debug"]],
|
||||
JMX4PERL_DEBUG_MAX_ENTRIES => [ "Maximum number of entries for storing debug info" , ["jolokia:type=Config","MaxDebugEntries"]],
|
||||
},
|
||||
|
||||
operation =>
|
||||
{
|
||||
# Memory
|
||||
MEMORY_GC => [ "Run a garbage collection", [ "java.lang:type=Memory", "gc" ]],
|
||||
|
||||
# Threads
|
||||
THREAD_DEADLOCKED => [ "Find cycles of threads that are in deadlock waiting to acquire object monitors", [ "java.lang:type=Threading", "findMonitorDeadlockedThreads"]],
|
||||
# TODO: Check for a default
|
||||
THREAD_DUMP => [ "Create a thread dump" ],
|
||||
|
||||
# Jmx4Perl
|
||||
JMX4PERL_HISTORY_MAX_ATTRIBUTE => [ "Set the size of the history for a specific attribute" , ["jolokia:type=Config","setHistoryEntriesForAttribute"]],
|
||||
JMX4PERL_HISTORY_MAX_OPERATION => [ "Set the size of the history for a specific operation" , ["jolokia:type=Config","setHistoryEntriesForOperation"]],
|
||||
JMX4PERL_HISTORY_RESET => [ "Reset the history for all attributes and operations" , ["jolokia:type=Config","resetHistoryEntries"]],
|
||||
JMX4PERL_DEBUG_INFO => [ "Print out latest debug info", ["jolokia:type=Config","debugInfo"]],
|
||||
JMX4PERL_SERVER_INFO => [ "Show information about registered MBeanServers", ["jolokia:type=Config","mBeanServerInfo"]]
|
||||
});
|
||||
|
||||
my %NAME_TO_ALIAS_MAP;
|
||||
my %ALIAS_OBJECT_MAP;
|
||||
my $initialized = undef;
|
||||
|
||||
# Import alias names directly into the name space
|
||||
# of the importer
|
||||
sub import {
|
||||
my $callpkg = caller;
|
||||
&_init() unless $initialized;
|
||||
do {
|
||||
no strict 'refs';
|
||||
for my $alias (keys %ALIAS_OBJECT_MAP) {
|
||||
my $object = $ALIAS_OBJECT_MAP{$alias};
|
||||
*{$callpkg."::".$alias} = sub { $object };
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
=item $alias = JMX::Jmx4Perl::Alias->by_name("MEMORY_HEAP_USAGE")
|
||||
|
||||
Get an alias object by a name lookup. The argument provided must be a string
|
||||
containing the name of an alias. If such an alias is not registered, this
|
||||
method returns C<undef>.
|
||||
|
||||
=cut
|
||||
|
||||
sub by_name {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $ret;
|
||||
my $alias = $NAME_TO_ALIAS_MAP{$name};
|
||||
#Try name in form "memory:heap:usage"
|
||||
if ($alias) {
|
||||
return $ALIAS_OBJECT_MAP{$alias};
|
||||
}
|
||||
# Try name in form "MEMORY_HEAP_USAGE"
|
||||
return $ALIAS_OBJECT_MAP{$name};
|
||||
}
|
||||
|
||||
=item JMX::Jmx4Perl::Alias->all
|
||||
|
||||
Get all aliases defined, sorted by alias name.
|
||||
|
||||
=cut
|
||||
|
||||
sub all {
|
||||
return sort { $a->alias cmp $b->alias } values %ALIAS_OBJECT_MAP;
|
||||
}
|
||||
|
||||
=item JMX::Jmx4Perl::Alias::help
|
||||
|
||||
Print out all registered aliases along with a short description
|
||||
|
||||
=cut
|
||||
|
||||
sub help {
|
||||
my @aliases = &JMX::Jmx4Perl::Alias::all;
|
||||
for my $alias (@aliases) {
|
||||
printf('%-30.30s %4.4s %s'."\n",$alias->alias,$alias->type,$alias->description);
|
||||
}
|
||||
}
|
||||
|
||||
# Build up various hashes
|
||||
sub _init {
|
||||
%NAME_TO_ALIAS_MAP = ();
|
||||
%ALIAS_OBJECT_MAP = ();
|
||||
for my $type (keys %ALIAS_MAP) {
|
||||
for my $alias (keys %{$ALIAS_MAP{$type}}) {
|
||||
my $name = lc $alias;
|
||||
$name =~ s/_/:/g;
|
||||
$NAME_TO_ALIAS_MAP{$name} = $alias;
|
||||
$ALIAS_OBJECT_MAP{$alias} =
|
||||
new JMX::Jmx4Perl::Alias::Object
|
||||
(
|
||||
alias => $alias,
|
||||
name => $name,
|
||||
type => $type,
|
||||
description => $ALIAS_MAP{$type}{$alias}[0],
|
||||
default => $ALIAS_MAP{$type}{$alias}[1],
|
||||
);
|
||||
}
|
||||
}
|
||||
$initialized = 1;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 ALIASES
|
||||
|
||||
The currently aliases are as shown below. Note, that this information might be
|
||||
outdated, to get the current one, use
|
||||
|
||||
perl -MJMX::Jmx4Perl::Alias -e 'JMX::Jmx4Perl::Alias::help'
|
||||
|
||||
CL_LOADED attr Number of currently loaded classes
|
||||
CL_TOTAL attr Number of classes loaded in total
|
||||
CL_UNLOADED attr Number of unloaded classes
|
||||
JMX4PERL_DEBUG attr Switch on/off debugging by setting this boolean
|
||||
JMX4PERL_DEBUG_INFO oper Print out latest debug info
|
||||
JMX4PERL_DEBUG_MAX_ENTRIES attr Maximum number of entries for storing debug info
|
||||
JMX4PERL_HISTORY_MAX_ATTRIBUTE oper Set the size of the history for a specific attribute
|
||||
JMX4PERL_HISTORY_MAX_ENTRIES attr Maximum number of entries per attribute/operation possible
|
||||
JMX4PERL_HISTORY_MAX_OPERATION oper Set the size of the history for a specific operation
|
||||
JMX4PERL_HISTORY_RESET oper Reset the history for all attributes and operations
|
||||
JMX4PERL_HISTORY_SIZE attr Size of the history of all attributes and operations in bytes
|
||||
JMX4PERL_SERVER_INFO oper Show information about registered MBeanServers
|
||||
MEMORY_GC oper Run a garbage collection
|
||||
MEMORY_HEAP attr Heap memory usage, multiple values
|
||||
MEMORY_HEAP_COMITTED attr Committed heap memory. That's the memory currently available for this JVM
|
||||
MEMORY_HEAP_INIT attr Initially allocated heap memory
|
||||
MEMORY_HEAP_MAX attr Maximum available heap memory
|
||||
MEMORY_HEAP_USED attr Used heap memory
|
||||
MEMORY_NONHEAP attr Non-Heap memory usage, multiple values
|
||||
MEMORY_NONHEAP_COMITTED attr Committed non-heap memory
|
||||
MEMORY_NONHEAP_INIT attr Initially allocated non-heap memory
|
||||
MEMORY_NONHEAP_MAX attr Maximum available non-heap memory
|
||||
MEMORY_NONHEAP_USED attr Used non-heap memory (like a 'method area')
|
||||
MEMORY_VERBOSE attr Switch on/off verbose messages concerning the garbage collector
|
||||
OS_CPU_TIME attr The cpu time used by this process
|
||||
OS_FILE_DESC_MAX attr Maximum number of open file descriptors
|
||||
OS_FILE_DESC_OPEN attr Number of open file descriptors
|
||||
OS_INFO_ARCH attr Architecture
|
||||
OS_INFO_NAME attr Operating system name
|
||||
OS_INFO_PROCESSORS attr Number of processors
|
||||
OS_INFO_VERSION attr Operating system version
|
||||
OS_MEMORY_PHYSICAL_FREE attr The amount of free physical memory for the OS
|
||||
OS_MEMORY_PHYSICAL_TOTAL attr The amount of total physical memory for the OS
|
||||
OS_MEMORY_SWAP_FREE attr The amount of free swap space for the OS
|
||||
OS_MEMORY_SWAP_TOTAL attr The amount of total swap memory available
|
||||
OS_MEMORY_VIRTUAL attr Size of virtual memory used by this process
|
||||
RUNTIME_ARGUMENTS attr Arguments when starting the JVM
|
||||
RUNTIME_BOOTCLASSPATH attr Bootclasspath
|
||||
RUNTIME_CLASSPATH attr Classpath
|
||||
RUNTIME_LIBRARY_PATH attr The LD_LIBRARY_PATH
|
||||
RUNTIME_NAME attr Name of the runtime
|
||||
RUNTIME_STARTTIME attr Time when starting the JVM
|
||||
RUNTIME_SYSTEM_PROPERTIES attr System properties
|
||||
RUNTIME_UPTIME attr Total uptime of JVM
|
||||
RUNTIME_VM_NAME attr Name of JVM
|
||||
RUNTIME_VM_VENDOR attr JVM Vendor
|
||||
RUNTIME_VM_VERSION attr Version of JVM
|
||||
SERVER_ADDRESS attr IP Address of server, numeric
|
||||
SERVER_HOSTNAME attr Hostname of server
|
||||
SERVER_NAME attr Name of server software
|
||||
SERVER_VERSION attr Version of application server
|
||||
THREAD_COUNT attr Active threads in the system
|
||||
THREAD_COUNT_DAEMON attr Count of threads marked as daemons in the system
|
||||
THREAD_COUNT_PEAK attr Peak thread count
|
||||
THREAD_COUNT_STARTED attr Count of threads started since system start
|
||||
THREAD_DEADLOCKED oper Find cycles of threads that are in deadlock waiting to acquire object monitors
|
||||
THREAD_DUMP oper Create a thread dump
|
||||
|
||||
=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;
|
||||
100
lib/JMX/Jmx4Perl/Alias/Object.pm
Normal file
100
lib/JMX/Jmx4Perl/Alias/Object.pm
Normal file
@@ -0,0 +1,100 @@
|
||||
package JMX::Jmx4Perl::Alias::Object;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Alias::Object - Internal object representing a concrete alias
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Simple object which describes an alias. It knows about the following read-only
|
||||
methods
|
||||
|
||||
=over
|
||||
|
||||
=item $alias->alias()
|
||||
|
||||
alias name in uppercase form (e.g. C<MEMORY_HEAP_USED>)
|
||||
|
||||
=item $alias->name()
|
||||
|
||||
alias name in lowercase format (e.g. C<memory:heap:used>)
|
||||
|
||||
=item $alias->description()
|
||||
|
||||
short description of the alias
|
||||
|
||||
=item $alias->default()
|
||||
|
||||
default values for an alias, which can be overwritten by a specific
|
||||
L<JMX::Jmx4Perl::Product::BaseHandler>. This is an arrayref with two values:
|
||||
The MBean's name and the attribute or operation name.
|
||||
|
||||
=item $alias->type()
|
||||
|
||||
Either C<attribute> or C<operation>, depending on what kind of MBean part the
|
||||
alias stands for.
|
||||
|
||||
=back
|
||||
|
||||
Additional, the C<"">, C<==> and C<!=> operators are overloaded to naturally
|
||||
compare and stringify alias values.
|
||||
|
||||
=cut
|
||||
|
||||
use Scalar::Util qw(refaddr);
|
||||
|
||||
use overload
|
||||
q{""} => sub { (shift)->as_string(@_) },
|
||||
q{==} => sub { (shift)->equals(@_) },
|
||||
q{!=} => sub { !(shift)->equals(@_) };
|
||||
|
||||
sub equals {
|
||||
return (ref $_[0] eq ref $_[1] && refaddr $_[0] == refaddr $_[1]) ? 1 : 0;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
return bless { @_ },ref($class) || $class;
|
||||
}
|
||||
|
||||
sub as_string { return $_[0]->{alias}; }
|
||||
sub alias { return shift->{alias}; }
|
||||
sub name { return shift->{name}; }
|
||||
sub description { return shift->{description}; }
|
||||
sub default { return shift->{default}; }
|
||||
sub type { return shift->{type}; }
|
||||
|
||||
=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;
|
||||
223
lib/JMX/Jmx4Perl/Config.pm
Normal file
223
lib/JMX/Jmx4Perl/Config.pm
Normal file
@@ -0,0 +1,223 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Config;
|
||||
use Data::Dumper;
|
||||
|
||||
my $HAS_CONFIG_GENERAL;
|
||||
|
||||
BEGIN {
|
||||
eval {
|
||||
require "Config/General.pm";
|
||||
};
|
||||
$HAS_CONFIG_GENERAL = $@ ? 0 : 1;
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Config - Configuration file support for Jmx4Perl
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=over
|
||||
|
||||
=item Configuration file format
|
||||
|
||||
# ================================================================
|
||||
# Sample configuration for jmx4perl
|
||||
|
||||
# localhost is the name how this config could accessed
|
||||
<Server localhost>
|
||||
# Options for JMX::Jmx4Perl->new, case is irrelevant
|
||||
Url = http://localhost:8080/j4p
|
||||
User = roland
|
||||
Password = test
|
||||
Product = JBoss
|
||||
|
||||
# HTTP proxy for accessing the agent
|
||||
<Proxy>
|
||||
Url = http://proxy:8001
|
||||
User = proxyuser
|
||||
Password = ppaasswwdd
|
||||
</Proxy>
|
||||
# Target for running j4p in proxy mode
|
||||
<Target>
|
||||
Url service:jmx:iiop://....
|
||||
User weblogic
|
||||
Password weblogic
|
||||
</Target>
|
||||
</Server>
|
||||
|
||||
=item Usage
|
||||
|
||||
my $config = new JMX::Jmx4Perl::Config($config_file);
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item $cfg = JMX::Jmx4Perl::Config->new($file_or_hash)
|
||||
|
||||
Create a new configuration object with the given file name. If no file name is
|
||||
given the configuration F<~/.j4p> is tried. In case the given file is a
|
||||
directory, a file F<dir/jxm4perl.cfg> is tried as configuration file.
|
||||
|
||||
If the file does not exist, C<server_config_exists> will alway return C<false> and
|
||||
C<get_server_config> will always return C<undef>
|
||||
|
||||
If a hash is given as argument, this hash is used to extract the server
|
||||
information.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $file_or_hash = shift;
|
||||
my $self = {};
|
||||
my $config = undef;;
|
||||
if (!ref($file_or_hash)) {
|
||||
my $file = $file_or_hash ? $file_or_hash : $ENV{HOME} . "/.j4p";
|
||||
$file = $file . "/jmx4perl.cfg" if -d $file;
|
||||
if (-e $file) {
|
||||
if ($HAS_CONFIG_GENERAL) {
|
||||
local $SIG{__WARN__} = sub {}; # Keep Config::General silent
|
||||
# when including things twice
|
||||
$config = {
|
||||
new Config::General(-ConfigFile => $file,-LowerCaseNames => 1,
|
||||
-UseApacheInclude => 1,-IncludeRelative => 1, -IncludeAgain => 0,
|
||||
-IncludeGlob => 1, -IncludeDirectories => 1, -CComments => 0)->getall
|
||||
};
|
||||
} else {
|
||||
warn "Configuration file $file found, but Config::General is not installed.\n" .
|
||||
"Please install Config::General, for the moment we are ignoring the content of $file\n\n";
|
||||
}
|
||||
} elsif (-d $file) {
|
||||
|
||||
}
|
||||
} elsif (ref($file_or_hash) eq "HASH") {
|
||||
$config = $file_or_hash;
|
||||
} else {
|
||||
die "Invalid argument ",$file_or_hash;
|
||||
}
|
||||
if ($config) {
|
||||
$self->{server_config} = &_extract_servers($config);
|
||||
$self->{servers} = [ values %{$self->{server_config}} ];
|
||||
map { $self->{$_} = $config->{$_ } } grep { $_ ne "server" } keys %$config;
|
||||
#print Dumper($self);
|
||||
}
|
||||
|
||||
bless $self,(ref($class) || $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $exists = $config->server_config_exists($name)
|
||||
|
||||
Check whether a configuration entry for the server with name $name
|
||||
exist.
|
||||
|
||||
=cut
|
||||
|
||||
sub server_config_exists {
|
||||
my $self = shift;
|
||||
my $name = shift || die "No server name given to reference to get config for";
|
||||
my $cfg = $self->get_server_config($name);
|
||||
return defined($cfg) ? 1 : 0;
|
||||
}
|
||||
|
||||
=item $server_config = $config->get_server_config($name)
|
||||
|
||||
Get the configuration for the given server or C<undef>
|
||||
if no such configuration exist.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_server_config {
|
||||
my $self = shift;
|
||||
my $name = shift || die "No server name given to reference to get config for";
|
||||
return $self->{server_config} ? $self->{server_config}->{$name} : undef;
|
||||
}
|
||||
|
||||
=item $servers = $config->get_servers
|
||||
|
||||
Get an arrayref to all configured servers or an empty arrayref.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_servers {
|
||||
my $self = shift;
|
||||
return $self->{servers} || [];
|
||||
}
|
||||
|
||||
sub _extract_servers {
|
||||
my $config = shift;
|
||||
my $servers = $config->{server};
|
||||
my $ret = {};
|
||||
return $ret unless $servers;
|
||||
if (ref($servers) eq "ARRAY") {
|
||||
# Its a list of servers using old style (no named section, but with
|
||||
# embedded 'name'
|
||||
for my $s (@$servers) {
|
||||
die "No name given for server config " . Dumper($s) . "\n" unless $s->{name};
|
||||
$ret->{$s->{name}} = $s;
|
||||
}
|
||||
return $ret;
|
||||
} elsif (ref($servers) eq "HASH") {
|
||||
for my $name (keys %$servers) {
|
||||
if (ref($servers->{$name}) eq "HASH") {
|
||||
# A single, 'named' server section
|
||||
$servers->{$name}->{name} = $name;
|
||||
} else {
|
||||
# It's a single server entry with 'old' style naming (e.g. no
|
||||
# named section but a 'Name' property
|
||||
my $ret = {};
|
||||
my $name = $servers->{name} || die "Missing name for server section ",Dumper($servers);
|
||||
$ret->{$name} = $servers;
|
||||
return $ret;
|
||||
}
|
||||
}
|
||||
return $servers;
|
||||
} else {
|
||||
die "Invalid configuration type ",ref($servers),"\n";
|
||||
}
|
||||
}
|
||||
|
||||
=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;
|
||||
327
lib/JMX/Jmx4Perl/J4psh.pm
Normal file
327
lib/JMX/Jmx4Perl/J4psh.pm
Normal file
@@ -0,0 +1,327 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::J4psh;
|
||||
|
||||
use JMX::Jmx4Perl::J4psh::CompletionHandler;
|
||||
use JMX::Jmx4Perl::J4psh::ServerHandler;
|
||||
use JMX::Jmx4Perl::J4psh::CommandHandler;
|
||||
use JMX::Jmx4Perl::J4psh::Shell;
|
||||
use JMX::Jmx4Perl::Request;
|
||||
use JMX::Jmx4Perl;
|
||||
use Data::Dumper;
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh - Central object for the JMX shell j4psh
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = ref($_[0]) eq "HASH" ? $_[0] : { @_ };
|
||||
bless $self,(ref($class) || $class);
|
||||
$self->init();
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->{complete} = new JMX::Jmx4Perl::J4psh::CompletionHandler($self);
|
||||
$self->{servers} = new JMX::Jmx4Perl::J4psh::ServerHandler($self);
|
||||
$self->{shell} = new JMX::Jmx4Perl::J4psh::Shell(config => $self->config->{shell},args => $self->args);;
|
||||
my $no_color_prompt = $self->{shell}->readline ne "Term::ReadLine::Gnu";
|
||||
$self->{commands} = new JMX::Jmx4Perl::J4psh::CommandHandler($self,$self->{shell},
|
||||
no_color_prompt => $no_color_prompt,
|
||||
command_packages => $self->command_packages);
|
||||
}
|
||||
|
||||
sub command_packages {
|
||||
return [ "JMX::Jmx4Perl::J4psh::Command" ];
|
||||
}
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
$self->{shell}->run;
|
||||
}
|
||||
|
||||
sub config {
|
||||
return shift->{config};
|
||||
}
|
||||
|
||||
sub args {
|
||||
return shift->{args};
|
||||
}
|
||||
|
||||
sub complete {
|
||||
return shift->{complete};
|
||||
}
|
||||
|
||||
sub commands {
|
||||
return shift->{commands};
|
||||
}
|
||||
|
||||
sub servers {
|
||||
return shift->{servers};
|
||||
}
|
||||
|
||||
sub server {
|
||||
return shift->{servers}->{server};
|
||||
}
|
||||
|
||||
sub color {
|
||||
return shift->{shell}->color(@_);
|
||||
}
|
||||
|
||||
sub term_height {
|
||||
return shift->{shell}->term_height;
|
||||
}
|
||||
|
||||
sub term_width {
|
||||
return shift->{shell}->term_width;
|
||||
}
|
||||
|
||||
sub agent {
|
||||
my $self = shift;
|
||||
my $agent = shift;
|
||||
if (defined($agent)) {
|
||||
$self->{agent} = $agent;
|
||||
}
|
||||
return $self->{agent};
|
||||
}
|
||||
|
||||
sub last_error {
|
||||
my $self = shift;
|
||||
my $error = shift;
|
||||
if (defined($error)) {
|
||||
if (length($error)) {
|
||||
$self->{last_error} = $error;
|
||||
} else {
|
||||
delete $self->{last_error};
|
||||
}
|
||||
}
|
||||
return $self->{last_error};
|
||||
}
|
||||
|
||||
sub create_agent {
|
||||
my $self = shift;
|
||||
my $args = shift;
|
||||
my $j4p = new JMX::Jmx4Perl($args);
|
||||
$self->load_list($j4p);
|
||||
$self->_legacy_check($j4p);
|
||||
$self->agent($j4p);
|
||||
return $j4p;
|
||||
}
|
||||
|
||||
sub load_list {
|
||||
my $self = shift;
|
||||
my $j4p = shift;
|
||||
|
||||
my $old_list = $self->{list};
|
||||
eval {
|
||||
my $req = new JMX::Jmx4Perl::Request(LIST);
|
||||
$self->{list} = $self->request($req,$j4p);
|
||||
($self->{mbeans_by_domain},$self->{mbeans_by_name}) = $self->_prepare_mbean_names($j4p,$self->{list});
|
||||
};
|
||||
if ($@) {
|
||||
$self->{list} = $old_list;
|
||||
die $@;
|
||||
}
|
||||
};
|
||||
|
||||
sub _legacy_check {
|
||||
my $self = shift;
|
||||
my $j4p = shift;
|
||||
my $resp = $j4p->version;
|
||||
my $version = $resp->{agent};
|
||||
$version =~ s/^(\d+(\.\d+)).*$/$1/;
|
||||
if ($version < 1.0) {
|
||||
$j4p->cfg('legacy-escape',1);
|
||||
}
|
||||
}
|
||||
|
||||
sub list {
|
||||
|
||||
return shift->{list};
|
||||
}
|
||||
|
||||
sub mbeans_by_domain {
|
||||
return shift->{mbeans_by_domain};
|
||||
}
|
||||
|
||||
sub mbeans_by_name {
|
||||
return shift->{mbeans_by_name};
|
||||
}
|
||||
|
||||
sub search_mbeans {
|
||||
my $self = shift;
|
||||
my $pattern = shift;
|
||||
$pattern = quotemeta($pattern);
|
||||
$pattern =~ s/\\?\*/.*/g;
|
||||
my @ret = ();
|
||||
my $mbeans_by_name = $self->mbeans_by_name();
|
||||
for my $name (sort keys %$mbeans_by_name) {
|
||||
push @ret,$mbeans_by_name->{$name} if $name =~ /$pattern/
|
||||
}
|
||||
return \@ret;
|
||||
}
|
||||
|
||||
sub request {
|
||||
my $self = shift;
|
||||
my $request = shift;
|
||||
my $j4p = shift || $self->agent;
|
||||
|
||||
my $response = $j4p->request($request);
|
||||
if ($response->is_error) {
|
||||
#print Dumper($response);
|
||||
if ($response->status == 404) {
|
||||
die "No agent running [Not found: ",$request->{mbean},",",$request->{operation},"].\n"
|
||||
} else {
|
||||
$self->{last_error} = $response->{error} .
|
||||
($response->stacktrace ? "\nStacktrace:\n" . $response->stacktrace : "");
|
||||
die $self->_prepare_error_message($response) . ".\n";
|
||||
}
|
||||
}
|
||||
return $response->value;
|
||||
}
|
||||
|
||||
sub _prepare_error_message {
|
||||
my $self = shift;
|
||||
my $resp = shift;
|
||||
my $st = $resp->stacktrace;
|
||||
return "Connection refused" if $resp->{error} =~ /Connection\s+refused/i;
|
||||
|
||||
if ($resp->{error} =~ /^(\d{3} [^\n]+)\n/m) {
|
||||
return $1;
|
||||
}
|
||||
return "Server Error: " . $resp->{error};
|
||||
}
|
||||
|
||||
|
||||
sub name {
|
||||
return "j4psh";
|
||||
}
|
||||
|
||||
|
||||
# =========================================
|
||||
|
||||
|
||||
sub _prepare_mbean_names {
|
||||
my $self = shift;
|
||||
my $j4p = shift;
|
||||
my $list = shift;
|
||||
my $mbeans_by_name = {};
|
||||
my $mbeans_by_domain = {};
|
||||
for my $domain (keys %$list) {
|
||||
for my $name (keys %{$list->{$domain}}) {
|
||||
my $full_name = $domain . ":" . $name;
|
||||
|
||||
my $e = {};
|
||||
my ($domain_p,$props) = $j4p->parse_name($full_name,1);
|
||||
$e->{domain} = $domain;
|
||||
$e->{props} = $props;
|
||||
$e->{info} = $list->{$domain}->{$name};
|
||||
my $keys = $self->_canonical_ordered_keys($props);
|
||||
$e->{string} = join ",", map { $_ . "=" . $props->{$_ } } @$keys;
|
||||
$e->{prompt} = length($e->{string}) > 25 ? $self->_prepare_prompt($props,25,$keys) : $e->{string};
|
||||
$e->{full} = $full_name;
|
||||
|
||||
$mbeans_by_name->{$full_name} = $e;
|
||||
my $k_v = $mbeans_by_domain->{$domain} || [];
|
||||
push @$k_v,$e;
|
||||
$mbeans_by_domain->{$domain} = $k_v;
|
||||
}
|
||||
}
|
||||
return ($mbeans_by_domain,$mbeans_by_name);
|
||||
}
|
||||
|
||||
# Order keys according to importance first and the alphabetically
|
||||
my @PREFERED_PROPS = qw(name type service);
|
||||
sub _order_keys {
|
||||
my $self = shift;
|
||||
my $props = shift;
|
||||
|
||||
# Get additional properties, not known to the prefered ones
|
||||
my $extra = { map { $_ => 1 } keys %$props };
|
||||
my @ret = ();
|
||||
for my $p (@PREFERED_PROPS) {
|
||||
if (exists($props->{$p})) {
|
||||
push @ret,$p;
|
||||
delete $extra->{$p};
|
||||
}
|
||||
}
|
||||
push @ret,sort keys %{$extra};
|
||||
return \@ret;
|
||||
}
|
||||
|
||||
# Canonical ordered means lexically sorted
|
||||
sub _canonical_ordered_keys {
|
||||
my $self = shift;
|
||||
my $props = shift;
|
||||
return [ sort keys %{$props} ];
|
||||
}
|
||||
|
||||
# Prepare property part of a mbean suitable for using in
|
||||
# a shell prompt
|
||||
sub _prepare_prompt {
|
||||
my $self = shift;
|
||||
my $props = shift;
|
||||
my $max = shift;
|
||||
my $keys = shift;
|
||||
my $len = $max - 3;
|
||||
my $ret = "";
|
||||
|
||||
for my $k (@$keys) {
|
||||
if (exists($props->{$k})) {
|
||||
my $p = $k . "=" . $props->{$k};
|
||||
if (!length($ret)) {
|
||||
$ret = $p;
|
||||
if (length($ret) > $max) {
|
||||
return substr($ret,0,$len) . "...";
|
||||
}
|
||||
} else {
|
||||
if (length($ret) + length($p) > $len) {
|
||||
return $ret . ", ...";
|
||||
} else {
|
||||
$ret .= "," . $p;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
=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;
|
||||
294
lib/JMX/Jmx4Perl/J4psh/Command.pm
Normal file
294
lib/JMX/Jmx4Perl/J4psh/Command.pm
Normal file
@@ -0,0 +1,294 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::J4psh::Command;
|
||||
use strict;
|
||||
use POSIX qw(strftime);
|
||||
use Term::Clui;
|
||||
|
||||
use Getopt::Long;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh::Command - Base object for commands
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the base command from which all j4psh commands should be extended. It
|
||||
provides registration hooks so that the command handler can determine the
|
||||
position of this command in the menu structure. Additionally it provides common
|
||||
methods useful for each command to perform its action.
|
||||
|
||||
A L<JMX::Jmx4Perl::J4psh::Command> is a collection of shell commands, grouped in a
|
||||
certain context. It can be reused in different contexts and hence can occur at
|
||||
different places in the menu structure.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item $command_handler = new JMX::Jmx4Perl::Command($context)
|
||||
|
||||
Constructor, which should not called be directly on this module but on a
|
||||
submodule. In fact, it will be called (indirectly) only by the
|
||||
L<JMX::Jmx4Perl::J4psh::CommandHandler> during the command registration process.
|
||||
The single argument required is the central context object.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $context = shift;
|
||||
my $self = ref($_[0]) eq "HASH" ? $_[0] : { @_ };
|
||||
bless $self,(ref($class) || $class);
|
||||
$self->{context} = $context;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $global_commands = $cmd->global_commands
|
||||
|
||||
This method is called by the command handler during registration in order to
|
||||
obtain the global commands which are always present in the menu. The default
|
||||
implementation returns C<undef> which means that no global commands should be
|
||||
registered. Overwrite this to provide a command hashref as known to
|
||||
L<Term::ShellUI> for setting the global commands.
|
||||
|
||||
=cut
|
||||
|
||||
sub global_commands {
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item $top_commands = $cmd->top_commands
|
||||
|
||||
This method is called by the command handler during registration in order to
|
||||
obtain the top commands which are present in the top level menu. The default
|
||||
implementation returns C<undef> which means that no top commands are to be
|
||||
registered. Overwrite this to provide a command hashref as known to
|
||||
L<Term::ShellUI> for setting the top commands.
|
||||
|
||||
=cut
|
||||
|
||||
sub top_commands {
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item $context = $cmd->context
|
||||
|
||||
Get the context object used during construction. This is a convenience method
|
||||
for sublassed commands.
|
||||
|
||||
=cut
|
||||
|
||||
sub context {
|
||||
return shift->{context};
|
||||
}
|
||||
|
||||
=item $complete_handler = $cmd->complete
|
||||
|
||||
Convenience method to get the L<JMX::Jmx4perl::J4psh::CompletionHandler> for getting
|
||||
various command line completions.
|
||||
|
||||
=cut
|
||||
|
||||
sub complete {
|
||||
return shift->{context}->complete;
|
||||
}
|
||||
|
||||
=item $agent = $cmd->agent
|
||||
|
||||
Convenience method to get the L<JMX::Jmx4Perl> agent in order to
|
||||
contact the server agent bundle (via L<JMX::Jmx4Perl>)
|
||||
|
||||
=cut
|
||||
|
||||
sub agent {
|
||||
return shift->{context}->agent;
|
||||
}
|
||||
|
||||
=item @colors = $cmd->color(@color_ids)
|
||||
|
||||
Return a list of ANSI color strings for the given symbolic color names which
|
||||
are looked up from the current color theme. If no coloring is enabled, empty
|
||||
strings are returned. This method dispatched directly to the underylying
|
||||
C<context> object.
|
||||
|
||||
=cut
|
||||
|
||||
sub color {
|
||||
return shift->{context}->color(@_);
|
||||
}
|
||||
|
||||
=item $cmd->push_on_stack("context",$cmds)
|
||||
|
||||
Rerturn a sub (closure) which can be used as a command to update the context
|
||||
stack managed by the command handler. Update in this sense means push the given
|
||||
context ("C<context>") on the stack, remembering the provided shell commands
|
||||
C<$cmds> for later use when traversing the stack upwards via C<..>
|
||||
|
||||
=cut
|
||||
|
||||
sub push_on_stack {
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
return sub {
|
||||
$self->{context}->{commands}->push_on_stack(@args);
|
||||
};
|
||||
}
|
||||
|
||||
=item $cmd->pop_off_stack
|
||||
|
||||
Go up one level in the stack
|
||||
|
||||
=cut
|
||||
|
||||
sub pop_off_stack {
|
||||
my $self = shift;
|
||||
$self->{context}->{commands}->pop_off_stack();
|
||||
}
|
||||
|
||||
=item $cmd->reset_stack
|
||||
|
||||
Reset the stack completely effectively jumping on top of it
|
||||
|
||||
=cut
|
||||
|
||||
sub reset_stack {
|
||||
my $self = shift;
|
||||
$self->{context}->{commands}->reset_stack();
|
||||
}
|
||||
|
||||
=item ($opts,@args) = $cmd->extract_command_options($spec,@args);
|
||||
|
||||
|
||||
Extract any options from a command specified via C<$spec>. This method uses
|
||||
L<Getopt::Long> for extrating the options. It returns a hashref with the
|
||||
extracted options and an array of remaining arguments
|
||||
|
||||
=cut
|
||||
|
||||
sub extract_command_options {
|
||||
my ($self,$spec,@args) = @_;
|
||||
my $opts = {};
|
||||
{
|
||||
local @ARGV = @args;
|
||||
GetOptions($opts,@{$spec});
|
||||
@args = @ARGV;
|
||||
}
|
||||
return ($opts,@args);
|
||||
}
|
||||
|
||||
=item $label = $cmd->format_date($time)
|
||||
|
||||
Formats a date like for C<ls -l>:
|
||||
|
||||
Dec 2 18:21
|
||||
Jun 23 2009
|
||||
|
||||
This format is especially useful when used in listing.
|
||||
|
||||
=cut
|
||||
|
||||
sub format_date {
|
||||
my $self = shift;
|
||||
my $time = shift;
|
||||
if (time - $time > 60*60*24*365) {
|
||||
return strftime "%b %d %Y",localtime($time);
|
||||
} else {
|
||||
return strftime "%b %d %H:%M",localtime($time);
|
||||
}
|
||||
}
|
||||
|
||||
=item $cmd->print_paged($txt,$nr_lines)
|
||||
|
||||
Use a pager for printing C<$txt> which has C<$nr_lines> lines. Only if
|
||||
C<$nr_lines> exceeds a certain limit (default: 24), then the pager is used,
|
||||
otherwise C<$txt> is printed directly.
|
||||
|
||||
=cut
|
||||
|
||||
sub print_paged {
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
my $nr = shift;
|
||||
if (!$nr) {
|
||||
$nr = scalar(split /\n/s,$text);
|
||||
}
|
||||
my $max_rows = $self->context->term_height;
|
||||
if (defined($nr) && $nr < $max_rows) {
|
||||
print $text;
|
||||
} else {
|
||||
view("",$text);
|
||||
}
|
||||
}
|
||||
|
||||
=item $trimmed = $cmd->trim_string($string,$max)
|
||||
|
||||
Trim a string C<$string> to a certain length C<$max>, i.e. if C<$string> is
|
||||
larger than C<$max>, then it is truncated to to C<$max-3> and C<...> is
|
||||
appended. If it is less or equal, than C<$string> is returned unchanged.
|
||||
|
||||
=cut
|
||||
|
||||
sub trim_string {
|
||||
my $self = shift;
|
||||
my $string = shift;
|
||||
my $max = shift;
|
||||
return length($string) > $max ? substr($string,0,$max-3) . "..." : $string;
|
||||
}
|
||||
|
||||
=item $converted = $cmd->convert_wildcard_pattern_to_regexp($orig)
|
||||
|
||||
Convert the wildcards C<*> and C<.> to their regexp equivalent and return a
|
||||
regular expression.
|
||||
|
||||
=cut
|
||||
|
||||
sub convert_wildcard_pattern_to_regexp {
|
||||
my $self = shift;
|
||||
my $wildcard = shift;
|
||||
$wildcard =~ s/\?/./g;
|
||||
$wildcard =~ s/\*/.*/g;
|
||||
return qr/^$wildcard$/i;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
=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;
|
||||
|
||||
128
lib/JMX/Jmx4Perl/J4psh/Command/Global.pm
Normal file
128
lib/JMX/Jmx4Perl/J4psh/Command/Global.pm
Normal file
@@ -0,0 +1,128 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::J4psh::Command::Global;
|
||||
use strict;
|
||||
use Term::ANSIColor qw(:constants);
|
||||
use Term::Clui;
|
||||
use base qw(JMX::Jmx4Perl::J4psh::Command);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh::Command::Global - Globally available commands
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head1 COMMANDS
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub name { "global" }
|
||||
|
||||
sub global_commands {
|
||||
my $self = shift;
|
||||
|
||||
return
|
||||
{
|
||||
"error" => {
|
||||
desc => "Show last error (if any)",
|
||||
proc => $self->cmd_last_error,
|
||||
doc => <<EOT
|
||||
Show the last error, if any occured. Including all
|
||||
stacktraces returned by the server.
|
||||
EOT
|
||||
},
|
||||
"help" => {
|
||||
desc => "Print online help",
|
||||
args => sub { shift->help_args(undef, @_); },
|
||||
method => sub { shift->help_call(undef, @_); },
|
||||
doc => <<EOT,
|
||||
help [<command>]
|
||||
h [<command>]
|
||||
|
||||
Print online help. Without option, show a summary. With
|
||||
option, show specific help for command <command>.
|
||||
EOT
|
||||
},
|
||||
"h" => { alias => "help", exclude_from_completion=>1},
|
||||
"history" => {
|
||||
desc => "Command History",
|
||||
doc => <<EOT,
|
||||
|
||||
history [-c] [-d <num>]
|
||||
|
||||
Specify a number to list the last N lines of history
|
||||
|
||||
Options:
|
||||
-c : Clear the command history
|
||||
-d <num> : Delete a single item <num>
|
||||
EOT
|
||||
args => "[-c] [-d] [number]",
|
||||
method => sub { shift->history_call(@_) },
|
||||
},
|
||||
"quit" => {
|
||||
desc => "Quit",
|
||||
maxargs => 0,
|
||||
method => sub { shift->exit_requested(1); },
|
||||
doc => <<EOT,
|
||||
Quit shell.
|
||||
EOT
|
||||
},
|
||||
"q" => { alias => 'quit', exclude_from_completion => 1 },
|
||||
"exit" => { alias => 'quit', exclude_from_completion => 1 }
|
||||
};
|
||||
}
|
||||
|
||||
sub cmd_last_error {
|
||||
my $self = shift;
|
||||
return sub {
|
||||
my $agent = $self->agent;
|
||||
my $txt = $self->context->last_error;
|
||||
if ($txt) {
|
||||
chomp $txt;
|
||||
print "$txt\n";
|
||||
} else {
|
||||
print "No errors\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=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;
|
||||
|
||||
721
lib/JMX/Jmx4Perl/J4psh/Command/MBean.pm
Normal file
721
lib/JMX/Jmx4Perl/J4psh/Command/MBean.pm
Normal file
@@ -0,0 +1,721 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::J4psh::Command::MBean;
|
||||
use strict;
|
||||
use base qw(JMX::Jmx4Perl::J4psh::Command);
|
||||
use JMX::Jmx4Perl::Util;
|
||||
use JMX::Jmx4Perl::Request;
|
||||
use Data::Dumper;
|
||||
use JSON;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh::Command::MBean - MBean commands
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head1 COMMANDS
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
# Name of this command
|
||||
sub name { "mbean" }
|
||||
|
||||
# We hook into as top-level commands
|
||||
sub top_commands {
|
||||
my $self = shift;
|
||||
return $self->agent ? $self->domain_commands : {};
|
||||
}
|
||||
|
||||
# The 'real' commands
|
||||
sub domain_commands {
|
||||
my $self = shift;
|
||||
return {
|
||||
"ls" => {
|
||||
desc => "List MBean Domains",
|
||||
proc => $self->cmd_list_domains,
|
||||
args => $self->complete->mbeans(all => 1),
|
||||
},
|
||||
"cd" => {
|
||||
desc => "Enter a domain",
|
||||
proc => sub {
|
||||
my $domain = join '',@_;
|
||||
$self->_cd_absolute($domain);
|
||||
},
|
||||
args => $self->complete->mbeans(all => 1),
|
||||
},
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
sub property_commands {
|
||||
my $self = shift;
|
||||
my $domain = shift;
|
||||
my $prop_cmds = $self->mbean_commands;
|
||||
return {
|
||||
"ls" => {
|
||||
desc => "List MBeans for a domain",
|
||||
proc => $self->cmd_list_domains($domain),
|
||||
args => $self->complete->mbeans(domain => $domain),
|
||||
},
|
||||
"cd" => {
|
||||
desc => "Enter a MBean",
|
||||
proc => sub {
|
||||
#print Dumper([@_]);
|
||||
#print Devel::StackTrace->new->as_string;
|
||||
my $input = join '',@_;
|
||||
if (!$self->_handle_navigation($input)) {
|
||||
if ($input =~ /:/) {
|
||||
$self->_cd_absolute($input);
|
||||
} else {
|
||||
$self->_cd_mbean($domain,$input);
|
||||
}
|
||||
}
|
||||
},
|
||||
args => $self->complete->mbeans(domain => $domain)
|
||||
},
|
||||
"pwd" => {
|
||||
desc => "Print currently selected domain",
|
||||
proc => sub {
|
||||
my ($s,$r) = $self->color("domain_name","reset");
|
||||
print $s . $domain . $r,":\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub mbean_commands {
|
||||
my $self = shift;
|
||||
my $mbean_props = shift;
|
||||
return {
|
||||
"ls" => {
|
||||
desc => "List MBeans for a domain.",
|
||||
doc => <<EOT,
|
||||
List all MBeans within a domain.
|
||||
|
||||
The following options are supported:
|
||||
|
||||
-a: Attributes only
|
||||
-o: Operations only
|
||||
|
||||
Wildcards are supported for filtering
|
||||
EOT
|
||||
proc => $self->cmd_show_mbean($mbean_props),
|
||||
#args => $self->complete->mbean_attribs($mbean_props),
|
||||
},
|
||||
"cd" => {
|
||||
desc => "Navigate up (..), to the top (/) or directly to another MBean",
|
||||
proc => sub {
|
||||
my $input = join '',@_;
|
||||
if (!$self->_handle_navigation($input)) {
|
||||
if ($input =~ /:/) {
|
||||
# "Absolute path"
|
||||
$self->_cd_absolute($input);
|
||||
} else {
|
||||
die "No MBean '",$input,"' known\n";
|
||||
}
|
||||
};
|
||||
},
|
||||
},
|
||||
"cat" => {
|
||||
desc => "Show value of an attribute",
|
||||
proc => $self->cmd_show_attributes($mbean_props),
|
||||
args => $self->complete->mbean_attributes($mbean_props),
|
||||
},
|
||||
"set" => {
|
||||
desc => "Set value of an attribute",
|
||||
proc => $self->cmd_set_attribute($mbean_props),
|
||||
args => $self->complete->mbean_attributes($mbean_props),
|
||||
},
|
||||
|
||||
"exec" => {
|
||||
desc => "Execute an operation",
|
||||
proc => $self->cmd_execute_operation($mbean_props),
|
||||
args => $self->complete->mbean_operations($mbean_props),
|
||||
},
|
||||
"pwd" => {
|
||||
desc => "Show the currently selected MBean",
|
||||
proc => sub {
|
||||
my ($d,$k,$v,$r) = $self->color("domain_name","property_key","property_value","reset");
|
||||
print $d . $mbean_props->{domain} . $r . ":" . $self->_color_props($mbean_props) . "\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub cmd_show_attributes {
|
||||
my $self = shift;
|
||||
my $m_info = shift;
|
||||
return sub {
|
||||
my $attributes = @_;
|
||||
my $info = $m_info->{info};
|
||||
my $mbean = $m_info->{full};
|
||||
my $context = $self->context;
|
||||
my $agent = $context->agent;
|
||||
my @attrs = ();
|
||||
for my $a (@_) {
|
||||
if ($a =~ /[\*\?]/) {
|
||||
my $regexp = $self->convert_wildcard_pattern_to_regexp($a);
|
||||
push @attrs, grep { $_ =~ /^$regexp$/ } keys %{$m_info->{info}->{attr}};
|
||||
} else {
|
||||
push @attrs,$a;
|
||||
}
|
||||
}
|
||||
# Use only unique values
|
||||
my %attrM = map { $_ => 1 } @attrs;
|
||||
@attrs = keys %attrM;
|
||||
if (@attrs == 0) {
|
||||
die "No attribute given\n";
|
||||
}
|
||||
my $request = JMX::Jmx4Perl::Request->new(READ,$mbean,\@attrs,{ignoreErrors => 1});
|
||||
my $response = $agent->request($request);
|
||||
if ($response->is_error) {
|
||||
die "Error: " . $response->error_text;
|
||||
}
|
||||
my $values = $response->value;
|
||||
my $p = "";
|
||||
my ($c_a,$c_r) = $self->color("attribute_name","reset");
|
||||
if (@attrs > 1) {
|
||||
# Print as list
|
||||
for my $attr (@attrs) {
|
||||
my $value = $values->{$attr};
|
||||
if ($self->_is_object($value)) {
|
||||
$p .= sprintf(" $c_a%-31.31s$c_r\n",$attr);
|
||||
$p .= $self->_dump($value);
|
||||
} else {
|
||||
$p .= sprintf(" $c_a%-31.31s$c_r %s\n",$attr,$self->_dump_scalar($value));
|
||||
}
|
||||
}
|
||||
} else {
|
||||
# Print single attribute
|
||||
my $value = $values->{$attrs[0]};
|
||||
if ($self->_is_object($value)) {
|
||||
$p .= $self->_dump($value);
|
||||
} else {
|
||||
$p .= $self->_dump_scalar($value)."\n";
|
||||
}
|
||||
}
|
||||
$self->print_paged($p);
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
sub cmd_set_attribute {
|
||||
my $self = shift;
|
||||
my $m_info = shift;
|
||||
return sub {
|
||||
my @args = @_;
|
||||
die "Usage: set <attribute-name> <value> [<path>]\n" if (@args != 2 && @args != 3);
|
||||
my $mbean = $m_info->{full};
|
||||
my $agent = $self->context->agent;
|
||||
my $req = new JMX::Jmx4Perl::Request(WRITE,$mbean,$args[0],$args[1],$args[2]);
|
||||
my $resp = $agent->request($req);
|
||||
if ($resp->is_error) {
|
||||
die $resp->error_text . "\n";
|
||||
}
|
||||
my $old_value = $resp->value;
|
||||
my ($c_l,$c_r) = $self->color("label","reset");
|
||||
|
||||
my $p = "";
|
||||
if ($self->_is_object($old_value)) {
|
||||
$p .= sprintf(" $c_l%-5.5ss$c_r\n","Old:");
|
||||
$p .= $self->_dump($old_value);
|
||||
} else {
|
||||
$p .= sprintf(" $c_l%-5.5s$c_r %s\n","Old:",$self->_dump_scalar($old_value));
|
||||
}
|
||||
$p .= sprintf(" $c_l%-5.5s$c_r %s\n","New:",$args[1]);;
|
||||
$self->print_paged($p);
|
||||
}
|
||||
}
|
||||
|
||||
sub cmd_execute_operation {
|
||||
my $self = shift;
|
||||
my $m_info = shift;
|
||||
return sub {
|
||||
my @args = @_;
|
||||
die "Usage: exec <attribute-name> <value> [<path>]\n" if (!@args);
|
||||
my $mbean = $m_info->{full};
|
||||
my $agent = $self->context->agent;
|
||||
my $req = new JMX::Jmx4Perl::Request(EXEC,$mbean,@args,{ignoreErrors => 1});
|
||||
my $resp = $agent->request($req);
|
||||
if ($resp->is_error) {
|
||||
die $resp->error_text . "\n";
|
||||
}
|
||||
my $value = $resp->value;
|
||||
my ($c_l,$c_r) = $self->color("label","reset");
|
||||
|
||||
my $p = "";
|
||||
if ($self->_is_object($value)) {
|
||||
$p .= sprintf(" $c_l%-7.7s$c_r\n","Return:");
|
||||
$p .= $self->_dump($value);
|
||||
} else {
|
||||
$p .= sprintf(" $c_l%-7.7s$c_r %s\n","Return:",$self->_dump_scalar($value));
|
||||
}
|
||||
$self->print_paged($p);
|
||||
}
|
||||
}
|
||||
|
||||
sub _is_object {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return JMX::Jmx4Perl::Util->is_object_to_dump($value);
|
||||
}
|
||||
|
||||
sub _dump {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return JMX::Jmx4Perl::Util->dump_value($value,{format => $self->_get_opt_or_config("format"),
|
||||
booleans => $self->_get_opt_or_config("booleans"),
|
||||
indent => $self->_get_opt_or_config("indent")});
|
||||
}
|
||||
|
||||
sub _dump_scalar {
|
||||
my $self = shift;
|
||||
return JMX::Jmx4Perl::Util->dump_scalar(shift,$self->_get_opt_or_config("booleans"));
|
||||
}
|
||||
|
||||
|
||||
sub _get_opt_or_config {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
|
||||
my $args = $self->context->args || {};
|
||||
my $config = $self->context->config || {};
|
||||
if (defined($args->{option}) && defined($args->{option}->{lc $key})) {
|
||||
return $args->{option}->{lc $key};
|
||||
} else {
|
||||
my $shell_config = $config->{shell} || {};
|
||||
return $shell_config->{lc $key};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# ===================================================================================================
|
||||
|
||||
=item cmd_list
|
||||
|
||||
List commands which can filter mbean by wildcard and knows about the
|
||||
following options:
|
||||
|
||||
=over
|
||||
|
||||
=item -l
|
||||
|
||||
Show attributes and operations
|
||||
|
||||
=back
|
||||
|
||||
If a single mbean is given as argument its details are shown.
|
||||
|
||||
=cut
|
||||
|
||||
sub cmd_list_domains {
|
||||
my $self = shift;
|
||||
my $domain = shift;
|
||||
return sub {
|
||||
my $context = $self->context;
|
||||
my $agent = $context->agent;
|
||||
print "Not connected to a server\n" and return unless $agent;
|
||||
my ($opts,@filters) = $self->extract_command_options(["l!"],@_);
|
||||
if ($domain) {
|
||||
if (@filters) {
|
||||
@filters = map { $domain . ":" .$_ } @filters
|
||||
} else {
|
||||
@filters = "$domain:*";
|
||||
}
|
||||
}
|
||||
# Show all
|
||||
if (@filters) {
|
||||
for my $filter (@filters) {
|
||||
my $regexp = $self->convert_wildcard_pattern_to_regexp($filter);
|
||||
my $mbean_filter;
|
||||
($filter,$mbean_filter) = ($1,$2) if ($filter && $filter =~ /(.*?):(.*)/) ;
|
||||
# It's a domain (pattern)
|
||||
$self->show_domain($opts,$self->_filter($context->mbeans_by_domain,$filter),$mbean_filter);
|
||||
}
|
||||
} else {
|
||||
$self->show_domain($opts,$self->_filter($context->mbeans_by_domain));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub cmd_show_mbean {
|
||||
my $self = shift;
|
||||
my $m_info = shift;
|
||||
return sub {
|
||||
my $info = $m_info->{info};
|
||||
my ($c_m,$c_a,$c_o,$c_r) = $self->color("mbean_name","attribute_name","operation_name","reset");
|
||||
my $op_len = 50 + length($c_o) + length($c_r);
|
||||
my ($do_show_attrs,$do_show_ops,$filters) = $self->_show_what_from_mbean($info,@_);
|
||||
|
||||
my $p = "";
|
||||
|
||||
my $name = $m_info->{full};
|
||||
$p .= $c_m . $name . $c_r;
|
||||
$p .= "\n\n";
|
||||
|
||||
#print Dumper($m_info);
|
||||
my $attrs = $info->{attr};
|
||||
if ($do_show_attrs) {
|
||||
my @lines = ();
|
||||
for my $attr (keys %$attrs) {
|
||||
my $line = "";
|
||||
if ($self->_pass_filter($attr,$filters)) {
|
||||
if (length($attr) > 31) {
|
||||
$line .= sprintf(" $c_a%s$c_r\n",$attr);
|
||||
$line .= sprintf(" %-31.31s %-13.13s %-4.4s %s\n",
|
||||
$self->_pretty_print_type($attrs->{$attr}->{type}),
|
||||
$attrs->{$attr}->{rw} eq "false" ? "[ro]" : "",$attrs->{$attr}->{desc});
|
||||
} else {
|
||||
$line .= sprintf(" $c_a%-31.31s$c_r %-13.13s %-4.4s %s\n",$attr,
|
||||
$self->_pretty_print_type($attrs->{$attr}->{type}),
|
||||
$attrs->{$attr}->{rw} eq "false" ? "[ro]" : "",$attrs->{$attr}->{desc});
|
||||
}
|
||||
push @lines,$line;
|
||||
}
|
||||
}
|
||||
if (@lines) {
|
||||
$p .= "Attributes:\n";
|
||||
$p .= join "",@lines;
|
||||
$p .= "\n";
|
||||
}
|
||||
}
|
||||
my $ops = $info->{op};
|
||||
if ($do_show_ops) {
|
||||
my @lines = ();
|
||||
for my $op (keys %$ops) {
|
||||
my $line = "";
|
||||
if ($self->_pass_filter($op,$filters)) {
|
||||
my $overloaded = ref($ops->{$op}) eq "ARRAY" ? $ops->{$op} : [ $ops->{$op} ];
|
||||
for my $m_info (@$overloaded) {
|
||||
my $sig = $self->_signature_to_print($op,$m_info);
|
||||
if (length($sig) > $op_len) {
|
||||
$line .= sprintf(" %s\n",$sig);
|
||||
$line .= sprintf(" %-50.50s %s\n","",$m_info->{desc}) if $m_info->{desc};
|
||||
} else {
|
||||
$line .= sprintf(" %-${op_len}.${op_len}s %s\n",$sig,$m_info->{desc});
|
||||
}
|
||||
}
|
||||
push @lines,$line;
|
||||
}
|
||||
}
|
||||
if (@lines) {
|
||||
$p .= "Operations:\n";
|
||||
$p .= join "",@lines;
|
||||
$p .= "\n";
|
||||
}
|
||||
}
|
||||
$self->print_paged($p);
|
||||
#print Dumper($info);
|
||||
}
|
||||
}
|
||||
|
||||
sub _pass_filter {
|
||||
my $self = shift;
|
||||
my $check = shift;
|
||||
my $regexps = shift;
|
||||
return 1 unless @$regexps;
|
||||
for my $regexp (@$regexps) {
|
||||
return 1 if $check =~ $regexp;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _show_what_from_mbean {
|
||||
my $self = shift;
|
||||
my ($info,@args) = @_;
|
||||
my ($opts,@filter) = $self->extract_command_options(["attributes|a!","operations|ops|o!"],@args);
|
||||
my $no_restrict = !defined($opts->{attributes}) && !defined($opts->{operations});
|
||||
my $show_attrs = $info->{attr} && keys %{$info->{attr}} && ($opts->{attributes} || $no_restrict);
|
||||
my $show_ops = $info->{op} && keys %{$info->{op}} && ($opts->{operations} || $no_restrict);
|
||||
my @filter_regexp = map {
|
||||
s/\*/.*/g;
|
||||
s/\?/./g;
|
||||
my $f = '^' . $_ . '$';
|
||||
qr/$f/i
|
||||
} @filter;
|
||||
return ($show_attrs,$show_ops,\@filter_regexp);
|
||||
}
|
||||
|
||||
sub _line_aligned {
|
||||
my $self = shift;
|
||||
my $max_lengths = shift;
|
||||
my $lengths = shift;
|
||||
my $parts = shift;
|
||||
my $opts = shift;
|
||||
|
||||
my $term_width = $self->context->term_width;
|
||||
my $overflow = $opts->{overflow_col} || 0;
|
||||
my $wrap_last = $opts->{wrap};
|
||||
my $ret = "";
|
||||
for my $i (0 .. $overflow) {
|
||||
if ($lengths->[$i] > $max_lengths->[$i]) {
|
||||
|
||||
# Do overflow
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _signature_to_print {
|
||||
my $self = shift;
|
||||
my $op = shift;
|
||||
my $info = shift;
|
||||
my ($c_o,$c_r) = $self->color("operation_name","reset");
|
||||
# print Dumper($info);
|
||||
my $ret = $self->_pretty_print_type($info->{ret}) . " ";
|
||||
$ret .= $c_o . $op . $c_r;
|
||||
$ret .= "(";
|
||||
my $args = $info->{args};
|
||||
my @arg_cl = ();
|
||||
for my $a (@$args) {
|
||||
if (ref($a) eq "HASH") {
|
||||
push @arg_cl,$self->_pretty_print_type($a->{type})
|
||||
} else {
|
||||
push @arg_cl,$self->_pretty_print_type($a);
|
||||
}
|
||||
}
|
||||
$ret .= join ",",@arg_cl;
|
||||
$ret .= ")";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub _pretty_print_type {
|
||||
my $self = shift;
|
||||
my $type = shift;
|
||||
my $suffix = "";
|
||||
my $type_p;
|
||||
if ($type eq "[J") {
|
||||
return "long[]";
|
||||
} elsif ($type =~ /^\[L(.*);/) {
|
||||
$type_p = $1;
|
||||
$suffix = "[]";
|
||||
} else {
|
||||
$type_p = $type;
|
||||
}
|
||||
$type_p =~ s/^.*\.([^\.]+)$/$1/;
|
||||
return $type_p . $suffix;
|
||||
}
|
||||
|
||||
sub show_mbeans {
|
||||
my $self = shift;
|
||||
my $opts = shift;
|
||||
my $infos = shift;
|
||||
my $mbean_filter;
|
||||
my $l = "";
|
||||
for my $m_info (sort { $a->{string} cmp $b->{string} } values %$infos) {
|
||||
my ($c_d,$c_s,$c_r) = $self->color("domain_name","stat_val","reset");
|
||||
$l .= $c_d . $m_info->{domain} . $c_r . ":";
|
||||
$l .= $self->_color_props($m_info) . "\n";
|
||||
}
|
||||
$self->print_paged($l);
|
||||
}
|
||||
|
||||
|
||||
sub show_domain {
|
||||
my $self = shift;
|
||||
my $opts = shift;
|
||||
my $infos = shift;
|
||||
|
||||
my $mbean_filter = shift;
|
||||
$mbean_filter = $self->convert_wildcard_pattern_to_regexp($mbean_filter) if $mbean_filter;
|
||||
my $text = "";
|
||||
for my $domain (keys %$infos) {
|
||||
my ($c_d,$c_reset) = $self->color("domain_name","reset");
|
||||
$text .= $c_d . "$domain:" . $c_reset . "\n";
|
||||
for my $m_info (sort { $a->{string} cmp $b->{string} } @{$infos->{$domain}}) {
|
||||
next if ($mbean_filter && $m_info->{string} !~ $mbean_filter);
|
||||
$text .= " ".$self->_color_props($m_info)."\n";
|
||||
$text .= $self->_list_details(" ",$m_info) if $opts->{l};
|
||||
}
|
||||
$text .= "\n";
|
||||
}
|
||||
$self->print_paged($text);
|
||||
}
|
||||
|
||||
sub _list_details {
|
||||
my $self = shift;
|
||||
my $indent = shift;
|
||||
my $m_info = shift;
|
||||
my ($c_s,$c_r) = $self->color("stat_val","reset");
|
||||
|
||||
my $line = "";
|
||||
if ($m_info->{info}->{desc}) {
|
||||
$line .= $m_info->{info}->{desc};
|
||||
}
|
||||
my $nr_attr = scalar(keys %{$m_info->{info}->{attr}});
|
||||
my $nr_op = scalar(keys %{$m_info->{info}->{op}});
|
||||
my $nr_notif = scalar(keys %{$m_info->{info}->{notif}});
|
||||
if ($nr_attr || $nr_op || $nr_notif) {
|
||||
my @f;
|
||||
push @f,"Attributes: " . $c_s . $nr_attr . $c_r if $nr_attr;
|
||||
push @f,"Operations: " . $c_s . $nr_op . $c_r if $nr_op;
|
||||
push @f,"Notifications: " . $c_s . $nr_notif . $c_r if $nr_notif;
|
||||
$line .= $indent . join(", ",@f) . "\n";
|
||||
}
|
||||
return $line;
|
||||
}
|
||||
|
||||
sub _color_props {
|
||||
my $self = shift;
|
||||
my $info = shift;
|
||||
my ($c_k,$c_v,$c_r) = $self->color("property_key","property_value","reset");
|
||||
#return Dumper($info);
|
||||
return join ",",map { $c_k . $_ . $c_r . "=" . $c_v . $info->{props}->{$_} . $c_r } sort keys %{$info->{props}};
|
||||
}
|
||||
|
||||
sub _filter {
|
||||
my $self = shift;
|
||||
my $map = shift;
|
||||
my @filters = @_;
|
||||
my @keys = keys %{$map};
|
||||
|
||||
if (@filters) {
|
||||
my %filtered;
|
||||
for my $f (@filters) {
|
||||
my $regexp = $self->convert_wildcard_pattern_to_regexp($f);
|
||||
for my $d (@keys) {
|
||||
$filtered{$d} = $map->{$d} if $d =~ $regexp;
|
||||
}
|
||||
}
|
||||
return \%filtered;
|
||||
} else {
|
||||
return $map;
|
||||
}
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub _cd_absolute {
|
||||
my $self = shift;
|
||||
my $domain = shift;
|
||||
my $props;
|
||||
|
||||
if ($domain) {
|
||||
$domain =~ s/:+$//;
|
||||
($domain,$props) = split(/:/,$domain,2) if $domain =~ /:/;
|
||||
}
|
||||
die "No domain $domain\n" unless $self->_check_domain($domain);
|
||||
$self->_check_mbean($domain,$props) if $props;
|
||||
$self->reset_stack;
|
||||
$self->_cd_domain($domain);
|
||||
$self->_cd_mbean($domain,$props) if $props;
|
||||
}
|
||||
|
||||
sub _check_mbean {
|
||||
my $self = shift;
|
||||
my $domain = shift;
|
||||
my $props = shift;
|
||||
$self->_get_mbean($domain,$props) || die "No MBean $domain:$props\n";
|
||||
}
|
||||
|
||||
sub _cd_domain {
|
||||
my $self = shift;
|
||||
my $domain = shift;
|
||||
die "No domain $domain\n" unless $self->_check_domain($domain);
|
||||
my $prop_cmds = $self->property_commands($domain);
|
||||
&{$self->push_on_stack($domain,$prop_cmds,":")};
|
||||
}
|
||||
|
||||
sub _cd_mbean {
|
||||
my $self = shift;
|
||||
my $domain = shift;
|
||||
my $mbean = shift;
|
||||
|
||||
my $mbean_props = $self->_check_mbean($domain,$mbean);
|
||||
my $mbean_cmds = $self->mbean_commands($mbean_props);
|
||||
&{$self->push_on_stack($mbean_props->{prompt},$mbean_cmds)};
|
||||
}
|
||||
|
||||
sub _check_domain {
|
||||
my $self = shift;
|
||||
my $domain = shift;
|
||||
my $context = $self->context;
|
||||
return exists($context->mbeans_by_domain->{$domain});
|
||||
|
||||
}
|
||||
|
||||
sub _get_mbean {
|
||||
my $self = shift;
|
||||
my $domain = shift;
|
||||
my $props = shift;
|
||||
my $context = $self->context;
|
||||
if ($props =~ /\*/) {
|
||||
my $mbeans = $context->search_mbeans($domain . ":" . $props);
|
||||
# TODO: If more than one, present a menu to select from. Now simply die
|
||||
return undef unless @{$mbeans};
|
||||
if (scalar(@$mbeans) > 1) {
|
||||
my $toomany = "";
|
||||
for my $m (@$mbeans) {
|
||||
my ($s,$r) = $self->color("mbean_name","reset");
|
||||
$toomany .=" >>> " . $s . $m->{full} . $r . "\n";
|
||||
}
|
||||
die "More than one MBean found:\n" . $toomany;
|
||||
}
|
||||
return $mbeans->[0];
|
||||
}
|
||||
return $context->mbeans_by_name->{$domain . ":" . $props};
|
||||
}
|
||||
|
||||
# Handle navigational commands
|
||||
sub _handle_navigation {
|
||||
my $self = shift;
|
||||
my $input = shift;
|
||||
if ($input eq "..") {
|
||||
$self->pop_off_stack;
|
||||
return 1;
|
||||
} elsif ($input eq "/" || !$input) {
|
||||
$self->reset_stack;
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub _filter_domains {
|
||||
|
||||
};
|
||||
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This file is part of osgish.
|
||||
|
||||
Osgish 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.
|
||||
|
||||
osgish 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 osgish. 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 JMX or OSGi in
|
||||
general), you might want to have a look at www.consol.com 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;
|
||||
|
||||
125
lib/JMX/Jmx4Perl/J4psh/Command/Server.pm
Normal file
125
lib/JMX/Jmx4Perl/J4psh/Command/Server.pm
Normal file
@@ -0,0 +1,125 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::J4psh::Command::Server;
|
||||
use strict;
|
||||
use Term::ANSIColor qw(:constants);
|
||||
|
||||
use base qw(JMX::Jmx4Perl::J4psh::Command);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh::Command::Server - Server related commands
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head1 COMMANDS
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub name { "server" }
|
||||
|
||||
sub top_commands {
|
||||
my $self = shift;
|
||||
return {
|
||||
"servers" => {
|
||||
desc => "Show all configured servers",
|
||||
proc => $self->cmd_server_list,
|
||||
doc => <<EOT
|
||||
List all servers stored in the configuration
|
||||
and those connected during this session
|
||||
(indicated by a '*')
|
||||
EOT
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub global_commands {
|
||||
my $self = shift;
|
||||
return {
|
||||
"connect" => {
|
||||
desc => "Connect to a server by its URL or symbolic name",
|
||||
minargs => 1, maxargs => 2,
|
||||
args => $self->complete->servers,
|
||||
proc => $self->cmd_connect,
|
||||
doc => <<EOT
|
||||
|
||||
connect <url or name> [<name>]
|
||||
|
||||
Connect to an agent. <url> is the URL under which the agent
|
||||
is reachable. Alternatively a <name> as stored in the configuration
|
||||
can be given. Is using the <url> form an additional <name>
|
||||
can be given which will be used as name in the server list.
|
||||
EOT
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
# Connect to a server
|
||||
sub cmd_connect {
|
||||
my $self = shift;
|
||||
return sub {
|
||||
my $arg = shift;
|
||||
my $name = shift;
|
||||
my $context = $self->context;
|
||||
$context->servers->connect_to_server($arg,$name);
|
||||
$context->commands->reset_stack;
|
||||
my ($yellow,$reset) = $context->color("host",RESET);
|
||||
print "Connected to " . $yellow . $context->server . $reset . " (" . $context->agent->url . ").\n" if $context->agent;
|
||||
}
|
||||
}
|
||||
|
||||
# Show all servers
|
||||
sub cmd_server_list {
|
||||
my $self = shift;
|
||||
return sub {
|
||||
my $context = $self->context;
|
||||
my $server_list = $context->servers->list;
|
||||
for my $s (@$server_list) {
|
||||
my ($ms,$me) = $context->color("host",RESET);
|
||||
my $sep = $s->{from_config} ? "-" : "*";
|
||||
printf " " . $ms . '%30.30s' . $me . ' %s %s' . "\n",$s->{name},$sep,$s->{url};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=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;
|
||||
|
||||
307
lib/JMX/Jmx4Perl/J4psh/CommandHandler.pm
Normal file
307
lib/JMX/Jmx4Perl/J4psh/CommandHandler.pm
Normal file
@@ -0,0 +1,307 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::J4psh::CommandHandler;
|
||||
|
||||
use strict;
|
||||
use Data::Dumper;
|
||||
use Term::ANSIColor qw(:constants);
|
||||
use Module::Find;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh::CommandHandler - Handler for j4psh commands
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This object is responsible for managing L<JMX::Jmx4Perl::Command> objects which
|
||||
are at the heart of j4psh and provide all features. During startup it
|
||||
registeres commands dynamically and pushes the L<JMX::Jmx4Perl::Shell> context to them
|
||||
for allowing to access the agent and other handlers.
|
||||
|
||||
Registration is occurs in two phases:
|
||||
|
||||
...
|
||||
|
||||
It also keeps a stack of so called navigational I<context> which can be used to
|
||||
provide a menu like structure (think of it like directories which can be
|
||||
entered). If the stack contains elements, the navigational commands C<..> and
|
||||
C</> are added to traverse the stack. C</> will always jump to the top of the
|
||||
stack (the I<root directory>) whereas C<..> will pop up one level in the stack
|
||||
(the I<parent directory>). Commands which want to manipulate the stack like
|
||||
pushing themselves on the stack should use the methods L</push_on_stack> or
|
||||
L</reset_stack> (for jumping to the top of the menu).
|
||||
|
||||
=cut
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item $command_handler = new JMX::Jmx4Perl::Shell::CommandHandler($context,$ui)
|
||||
|
||||
Create a new command handler object. The arguments to be passed are the context
|
||||
object (C<$context>) and the shell object (C<$shell>) in order to update the
|
||||
shell's current command set.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $context = shift || "No context object given";
|
||||
my $shell = shift || "No shell given";
|
||||
my $extra = shift;
|
||||
$extra = { $extra, @_ } unless ref($extra) eq "HASH";
|
||||
my $self = {
|
||||
context => $context,
|
||||
shell => $shell,
|
||||
%{$extra}
|
||||
};
|
||||
$self->{stack} = [];
|
||||
bless $self,(ref($class) || $class);
|
||||
$shell->term->prompt($self->_prompt);
|
||||
$self->_register_commands;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $comand_handler->push_on_stack($context,$cmds)
|
||||
|
||||
Update the stack with an entry of name C<$context> which provides the commands
|
||||
C<$cmds>. C<$cmds> must be a hashref as known to L<Term::ShellUI>, whose
|
||||
C<commands> method is used to update the shell. Additionally it updates the
|
||||
shell's prompt to reflect the state of the stack.
|
||||
|
||||
=cut
|
||||
|
||||
sub push_on_stack {
|
||||
my $self = shift;
|
||||
# The new context
|
||||
my $context = shift;
|
||||
# Sub-commands within the context
|
||||
my $sub_cmds = shift;
|
||||
my $separator = shift || "/";
|
||||
my $contexts = $self->{stack};
|
||||
push @$contexts,{ name => $context, cmds => $sub_cmds, separator => $separator };
|
||||
#print Dumper(\@contexts);
|
||||
|
||||
my $shell = $self->{shell};
|
||||
# Set sub-commands
|
||||
$shell->commands
|
||||
({
|
||||
%$sub_cmds,
|
||||
%{$self->_global_commands},
|
||||
%{$self->_navigation_commands},
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
=item $command_handler->reset_stack
|
||||
|
||||
Reset the stack and install the top and global commands as collected from the
|
||||
registered L<OSGi::Osgish::Command>.
|
||||
|
||||
=cut
|
||||
|
||||
sub reset_stack {
|
||||
my $self = shift;
|
||||
my $shell = $self->{shell};
|
||||
$shell->commands({ %{$self->_top_commands}, %{$self->_global_commands}});
|
||||
$self->{stack} = [];
|
||||
}
|
||||
|
||||
=item $command = $command_handler->command($command_name)
|
||||
|
||||
Get a registered command by name
|
||||
|
||||
=cut
|
||||
|
||||
sub command {
|
||||
my $self = shift;
|
||||
my $name = shift || die "No command name given";
|
||||
return $self->{commands}->{$name};
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
# ============================================================================
|
||||
|
||||
sub _top_commands {
|
||||
my $self = shift;
|
||||
my $top = $self->{top_commands};
|
||||
my @ret = ();
|
||||
for my $command (values %$top) {
|
||||
push @ret, %{$command->top_commands};
|
||||
}
|
||||
return { @ret };
|
||||
}
|
||||
|
||||
sub _global_commands {
|
||||
my $self = shift;
|
||||
my $globals = $self->{global_commands};
|
||||
my @ret = ();
|
||||
for my $command (values %$globals) {
|
||||
push @ret, %{$command->global_commands};
|
||||
}
|
||||
return { @ret };
|
||||
}
|
||||
|
||||
|
||||
sub _navigation_commands {
|
||||
my $self = shift;
|
||||
my $shell = $self->{shell};
|
||||
my $contexts = $self->{stack};
|
||||
if (@$contexts > 0) {
|
||||
return
|
||||
{".." => {
|
||||
desc => "Go up one level",
|
||||
proc =>
|
||||
sub {
|
||||
$self->pop_off_stack();
|
||||
}
|
||||
},
|
||||
"/" => {
|
||||
desc => "Go to the top level",
|
||||
proc =>
|
||||
sub {
|
||||
$self->reset_stack();
|
||||
}
|
||||
}
|
||||
};
|
||||
} else {
|
||||
return {};
|
||||
}
|
||||
}
|
||||
|
||||
# Go up one in the hierarchy
|
||||
sub pop_off_stack {
|
||||
my $self = shift;
|
||||
my $shell = $self->{shell};
|
||||
my $stack = $self->{stack};
|
||||
my $parent = pop @$stack;
|
||||
if (@$stack > 0) {
|
||||
$shell->commands
|
||||
({
|
||||
%{$stack->[$#{$stack}]->{cmds}},
|
||||
%{$self->_global_commands},
|
||||
%{$self->_navigation_commands},
|
||||
}
|
||||
);
|
||||
} else {
|
||||
$shell->commands({
|
||||
%{$self->_top_commands},
|
||||
%{$self->_global_commands},
|
||||
});
|
||||
}
|
||||
}
|
||||
|
||||
sub _register_commands {
|
||||
my $self = shift;
|
||||
my $context = $self->{context};
|
||||
my $modules = $self->find_commands();
|
||||
my $commands = {};
|
||||
my $top = {};
|
||||
my $globals = {};
|
||||
for my $module (@$modules) {
|
||||
my $file = $module;
|
||||
$file =~ s/::/\//g;
|
||||
require $file . ".pm";
|
||||
$module->import;
|
||||
my $command = eval "$module->new(\$context)";
|
||||
die "Cannot register $module: ",$@ if $@;
|
||||
$commands->{$command->name} = $command;
|
||||
my $top_cmd = $command->top_commands;
|
||||
if ($top_cmd) {
|
||||
$top->{$command->name} = $command;
|
||||
}
|
||||
my $global_cmd = $command->global_commands;
|
||||
if ($global_cmd) {
|
||||
$globals->{$command->name} = $command;
|
||||
}
|
||||
}
|
||||
$self->{commands} = $commands;
|
||||
$self->{top_commands} = $top;
|
||||
$self->{global_commands} = $globals;
|
||||
$self->reset_stack;
|
||||
}
|
||||
|
||||
sub find_commands {
|
||||
my $self = shift;
|
||||
my $command_pkgs = ref($self->{command_packages}) eq "ARRAY" ? $self->{command_packages} : [ $self->{command_packages} ];
|
||||
my @modules = ();
|
||||
for my $pkg (@{$command_pkgs}) {
|
||||
for my $command (findsubmod $pkg) {
|
||||
next unless $command;
|
||||
push @modules,$command;
|
||||
}
|
||||
}
|
||||
if ($self->{command_modules}) {
|
||||
my $command_modules =
|
||||
ref($self->{command_modules}) eq "ARRAY" ? $self->{command_modules} : [ $self->{command_modules} ];
|
||||
for my $command (@$command_modules) {
|
||||
push @modules,$command;
|
||||
}
|
||||
}
|
||||
return \@modules;
|
||||
}
|
||||
|
||||
sub _prompt {
|
||||
my $self = shift;
|
||||
my $context = $self->{context};
|
||||
my $shell = $self->{shell};
|
||||
return sub {
|
||||
my $term = shift;
|
||||
my $stack = $self->{stack};
|
||||
my $agent = $context->agent;
|
||||
my ($c_host,$c_context,$c_empty,$reset) =
|
||||
$self->{no_color_prompt} ? ("","","","") : $shell->color("host","prompt_context","prompt_empty",RESET,{escape => 1});
|
||||
my $p = "[";
|
||||
$p .= $agent ? $c_host . $context->server : $c_empty . $context->name;
|
||||
$p .= $reset;
|
||||
$p .= " " . $c_context if @$stack;
|
||||
for my $i (0 .. $#{$stack}) {
|
||||
$p .= $stack->[$i]->{name};
|
||||
$p .= $i < $#{$stack} ? $stack->[$i]->{separator} : $reset;
|
||||
}
|
||||
$p .= "] : ";
|
||||
return $p;
|
||||
};
|
||||
}
|
||||
|
||||
=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;
|
||||
|
||||
|
||||
|
||||
220
lib/JMX/Jmx4Perl/J4psh/CompletionHandler.pm
Normal file
220
lib/JMX/Jmx4Perl/J4psh/CompletionHandler.pm
Normal file
@@ -0,0 +1,220 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::J4psh::CompletionHandler;
|
||||
|
||||
use strict;
|
||||
use File::Spec;
|
||||
use Data::Dumper;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh::CompletionHandler - Custom completion routines for readline.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $context = shift || die "No context object given";
|
||||
my $self = {
|
||||
context => $context
|
||||
};
|
||||
bless $self,(ref($class) || $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub files_extended {
|
||||
my $self = shift;
|
||||
return sub {
|
||||
my $term = shift;
|
||||
my $cmpl = shift;
|
||||
my $filter = undef;
|
||||
|
||||
$term->suppress_completion_append_character();
|
||||
|
||||
use File::Spec;
|
||||
my @path = File::Spec->splitdir($cmpl->{str} || ".");
|
||||
my $dir = File::Spec->catdir(@path[0..$#path-1]);
|
||||
my $lookup_dir = $dir;
|
||||
if ($dir =~ /^\~(.*)/) {
|
||||
my $user = $1 || "";
|
||||
$lookup_dir = glob("~$user");
|
||||
}
|
||||
my $file = $path[$#path];
|
||||
$file = '' unless $cmpl->{str};
|
||||
my $flen = length($file);
|
||||
|
||||
my @files = ();
|
||||
$lookup_dir = length($lookup_dir) ? $lookup_dir : ".";
|
||||
if (opendir(DIR, $lookup_dir)) {
|
||||
if ($filter) {
|
||||
@files = grep { substr($_,0,$flen) eq $file && $file =~ $filter } readdir DIR;
|
||||
} else {
|
||||
@files = grep { substr($_,0,$flen) eq $file } readdir DIR;
|
||||
}
|
||||
closedir DIR;
|
||||
# eradicate dotfiles unless user's file begins with a dot
|
||||
@files = grep { /^[^.]/ } @files unless $file =~ /^\./;
|
||||
# reformat filenames to be exactly as user typed
|
||||
my @ret = ();
|
||||
for my $file (@files) {
|
||||
$file .= "/" if -d $lookup_dir . "/" . $file;
|
||||
$file = $dir eq '/' ? "/$file" : "$dir/$file" if length($dir);
|
||||
push @ret,$file;
|
||||
}
|
||||
return \@ret;
|
||||
} else {
|
||||
$term->completemsg("Couldn't read dir: $!\n");
|
||||
return [];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub servers {
|
||||
my $self = shift;
|
||||
return sub {
|
||||
my ($term,$cmpl) = @_;
|
||||
my $context = $self->{context};
|
||||
my $server_list = $context->servers->list;
|
||||
return [] unless @$server_list;
|
||||
my $str = $cmpl->{str} || "";
|
||||
my $len = length($str);
|
||||
return [ grep { substr($_,0,$len) eq $str } map { $_->{name} } @$server_list ];
|
||||
}
|
||||
}
|
||||
|
||||
# Complete on mbean names
|
||||
sub mbeans {
|
||||
my $self = shift;
|
||||
my %args = @_;
|
||||
my $attr;
|
||||
return sub {
|
||||
my ($term,$cmpl) = @_;
|
||||
$term->suppress_completion_escape();
|
||||
my $all = $args{all};
|
||||
my $domain = $args{domain};
|
||||
#$term->{debug_complete}=5;
|
||||
my $context = $self->{context};
|
||||
my $mbeans = $context->mbeans_by_domain;
|
||||
my $str = $cmpl->{str} || "";
|
||||
my $len = length($str);
|
||||
if ($domain) {
|
||||
my $attrs = $mbeans->{$domain};
|
||||
return [] unless $attrs;
|
||||
my @kv = map { $_->{string} } @$attrs;
|
||||
return [ map { $_ } grep { substr($_,0,$len) eq $str } @kv ];
|
||||
} else {
|
||||
($domain,$attr) = split(/:/,$str,2);
|
||||
if ($attr || $str =~ /:$/) {
|
||||
# Complete on attributes
|
||||
my $attrs = $mbeans->{$domain};
|
||||
return [] unless $attrs;
|
||||
my @kv = map { $_->{string} } @$attrs;
|
||||
if ($attr) {
|
||||
return [ map { $domain . ":" . $_ } grep { substr($_,0,length($attr)) eq $attr } @kv ];
|
||||
} else {
|
||||
return [ map { $domain . ":" . $_} @kv ];
|
||||
}
|
||||
} else {
|
||||
# Complete on domains
|
||||
my $domains = $str ? [ grep { substr($_,0,$len) eq $str } keys %$mbeans ] : [ keys %$mbeans ];
|
||||
if ($all) {
|
||||
$term->suppress_completion_append_character();
|
||||
}
|
||||
return $domains;
|
||||
}
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
sub mbean_attributes {
|
||||
return shift->_complete_attr_op(shift,"attr");
|
||||
}
|
||||
|
||||
sub mbean_operations {
|
||||
return shift->_complete_attr_op(shift,"op");
|
||||
}
|
||||
|
||||
sub _complete_attr_op {
|
||||
my $self = shift;
|
||||
my $m_info = shift;
|
||||
my $what = shift;
|
||||
my $attr;
|
||||
#print "> ",Dumper($m_info->{info}->{attr});
|
||||
return sub {
|
||||
my ($term,$cmpl) = @_;
|
||||
$term->suppress_completion_escape();
|
||||
my $attrs = $m_info->{info}->{$what};
|
||||
#$term->{debug_complete}=5;
|
||||
my $context = $self->{context};
|
||||
my $str = $cmpl->{str} || "";
|
||||
my $len = length($str);
|
||||
return [ grep { substr($_,0,$len) eq $str } keys %$attrs ];
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
# Method for completing based on key=value for an
|
||||
# arbitrary order of key, value pairs
|
||||
sub _complete_props {
|
||||
my $self = shift;
|
||||
# List of MBeans for this domain
|
||||
my $mbeans_ref = shift;
|
||||
my @mbeans = ( @{$mbeans_ref} );
|
||||
my $input = shift;
|
||||
my $context = $self->{context};
|
||||
# Get all already completed
|
||||
my @parts = split /,/,$input;
|
||||
my $last = pop @parts;
|
||||
# Filter out already set types
|
||||
for my $p (@parts) {
|
||||
my ($k,$v) = split /=/m,$p,2;
|
||||
@mbeans = grep { $_->{props}->{$k} eq $v } @mbeans;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
=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;
|
||||
|
||||
|
||||
|
||||
207
lib/JMX/Jmx4Perl/J4psh/ServerHandler.pm
Normal file
207
lib/JMX/Jmx4Perl/J4psh/ServerHandler.pm
Normal file
@@ -0,0 +1,207 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::J4psh::ServerHandler;
|
||||
|
||||
use strict;
|
||||
use Term::ANSIColor qw(:constants);
|
||||
use Data::Dumper;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh::ServerHandler - Handler for coordinating server access
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $context = shift || die "No context given";
|
||||
my $args = shift;
|
||||
my $self = {
|
||||
context => $context,
|
||||
args => $context->{args},
|
||||
config => $context->{config},
|
||||
};
|
||||
bless $self,(ref($class) || $class);
|
||||
my $server = $self->_init_server_list($context->{initial_server},$context);
|
||||
$self->connect_to_server($server) if $server;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub connect_to_server {
|
||||
my $self = shift;
|
||||
my $server = shift;
|
||||
my $name = shift;
|
||||
|
||||
my $server_map = $self->{server_map};
|
||||
my $s = $server_map->{$server};
|
||||
unless ($s) {
|
||||
unless ($server =~ m|^\w+://([\w]+:\w+@)?[\d\.\w:]+(:(\d+))?/|) {
|
||||
print "Invalid URL $server\n";
|
||||
return;
|
||||
}
|
||||
$name ||= $self->_prepare_server_name($server);
|
||||
my $entry = { name => $name, url => $server };
|
||||
push @{$self->{server_list}},$entry;
|
||||
$self->{server_map}->{$name} = $entry;
|
||||
$s = $entry;
|
||||
}
|
||||
my $context = $self->{context};
|
||||
my ($old_server,$old_agent) = ($self->server,$context->agent);
|
||||
eval {
|
||||
$self->create_agent($s->{name}) || die "Unknown $server (not an alias nor a proper URL).\n";;
|
||||
$self->{server} = $s->{name};
|
||||
$context->last_error("");
|
||||
};
|
||||
if ($@) {
|
||||
$context->last_error($@);
|
||||
$self->{server} = $old_server if $old_server;
|
||||
$context->agent($old_agent);
|
||||
die $@;
|
||||
}
|
||||
}
|
||||
|
||||
sub server {
|
||||
return shift->{server};
|
||||
}
|
||||
|
||||
sub list {
|
||||
my $self = shift;
|
||||
return $self->{server_list};
|
||||
}
|
||||
|
||||
|
||||
sub _init_server_list {
|
||||
my $self = shift;
|
||||
my $server = shift;
|
||||
my $context = shift;
|
||||
my $config = $context->{config};
|
||||
my $args = $context->{args};
|
||||
my @servers = map { { name => $_->{name}, url => $_->{url}, from_config => 1 } } @{$config->get_servers};
|
||||
my $ret_server;
|
||||
if ($server) {
|
||||
my $config_s = $config->get_server_config($server);
|
||||
if ($config_s) {
|
||||
my $found = 0;
|
||||
my $i = 0;
|
||||
my $entry = { name => $server, url => $config_s->{url}, from_config => 1 } ;
|
||||
for my $s (@servers) {
|
||||
if ($s->{name} eq $server) {
|
||||
$servers[$i] = $entry;
|
||||
$found = 1;
|
||||
last;
|
||||
}
|
||||
$i++;
|
||||
}
|
||||
push @servers,$entry unless $found;
|
||||
$ret_server = $config_s->{name};
|
||||
} else {
|
||||
die "Invalid URL ",$server,"\n" unless ($server =~ m|^\w+://|);
|
||||
my $name = $self->_prepare_server_name($server);
|
||||
push @servers,{ name => $name, url => $server };
|
||||
$ret_server = $name;
|
||||
}
|
||||
}
|
||||
$self->{server_list} = \@servers;
|
||||
$self->{server_map} = { map { $_->{name} => $_ } @servers };
|
||||
return $ret_server;
|
||||
}
|
||||
|
||||
# =========================================================================================
|
||||
|
||||
sub _prepare_server_name {
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
if ($url =~ m|^\w+://([^/]+)/?|) {
|
||||
return $1;
|
||||
} else {
|
||||
return $url;
|
||||
}
|
||||
}
|
||||
|
||||
sub create_agent {
|
||||
my $self = shift;
|
||||
my $server = shift;
|
||||
return undef unless $server;
|
||||
# TODO: j4p_args, jmx_config;
|
||||
my $j4p_args = $self->_j4p_args($self->{args} || {});
|
||||
my $jmx_config = $self->{config} || {};
|
||||
my $sc = $self->{server_map}->{$server};
|
||||
return undef unless $sc;
|
||||
my $context = $self->{context};
|
||||
if ($sc->{from_config}) {
|
||||
$context->create_agent({ %$j4p_args, server => $server, config => $jmx_config});
|
||||
} else {
|
||||
$context->create_agent({ %$j4p_args, url => $sc->{url}});
|
||||
}
|
||||
}
|
||||
|
||||
# Extract connection related args from the command line arguments
|
||||
sub _j4p_args {
|
||||
my $self = shift;
|
||||
my $o = shift;
|
||||
my $ret = { };
|
||||
|
||||
for my $arg (qw(user password)) {
|
||||
if (defined($o->{$arg})) {
|
||||
$ret->{$arg} = $o->{$arg};
|
||||
}
|
||||
}
|
||||
|
||||
if (defined($o->{proxy})) {
|
||||
my $proxy = {};
|
||||
$proxy->{url} = $o->{proxy};
|
||||
for my $k (qw(proxy-user proxy-password)) {
|
||||
$proxy->{$k} = defined($o->{$k}) if $o->{$k};
|
||||
}
|
||||
$ret->{proxy} = $proxy;
|
||||
}
|
||||
if (defined($o->{target})) {
|
||||
$ret->{target} = {
|
||||
url => $o->{target},
|
||||
$o->{'target-user'} ? (user => $o->{'target-user'}) : (),
|
||||
$o->{'target-password'} ? (password => $o->{'target-password'}) : (),
|
||||
};
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=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;
|
||||
|
||||
284
lib/JMX/Jmx4Perl/J4psh/Shell.pm
Normal file
284
lib/JMX/Jmx4Perl/J4psh/Shell.pm
Normal file
@@ -0,0 +1,284 @@
|
||||
package JMX::Jmx4Perl::J4psh::Shell;
|
||||
|
||||
use strict;
|
||||
use Term::ShellUI;
|
||||
use Term::ANSIColor qw(:constants);
|
||||
use Data::Dumper;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::J4psh::Shell - Facade to Term::ShellUI
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=cut
|
||||
|
||||
my $USE_TERM_SIZE;
|
||||
my $USE_SEARCH_PATH;
|
||||
BEGIN {
|
||||
$USE_TERM_SIZE = eval 'use Term::Size qw/chars/; 1';
|
||||
$USE_SEARCH_PATH = eval 'use File::SearchPath qw/searchpath/; 1';
|
||||
no warnings 'redefine';
|
||||
*Text::Shellwords::Cursor::join_line = sub {
|
||||
my $self = shift;
|
||||
my $intoks = shift;
|
||||
|
||||
my $str = "";
|
||||
my $nsp = "";
|
||||
my $last_tok = "";
|
||||
for (@$intoks) {
|
||||
$nsp = /^(['"])(.*)\1/ || $last_tok =~ /^(['"])(.*)\1/ ? "" : " ";
|
||||
$str .= $nsp . $_;
|
||||
$last_tok = $_;
|
||||
}
|
||||
$str =~ s/^\s*(.*?)\s*$/$1/;
|
||||
return $str;
|
||||
};
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = ref($_[0]) eq "HASH" ? $_[0] : { @_ };
|
||||
bless $self,(ref($class) || $class);
|
||||
$self->_init;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub term {
|
||||
return shift->{term};
|
||||
}
|
||||
|
||||
sub commands {
|
||||
my $self = shift;
|
||||
$self->{term}->commands(@_);
|
||||
}
|
||||
|
||||
# Run ShellUI and never return. Provide some special
|
||||
# ReadLine treatment
|
||||
sub run {
|
||||
my $self = shift;
|
||||
my $t = $self->term;
|
||||
|
||||
#$t->{debug_complete}=5;
|
||||
$t->run;
|
||||
}
|
||||
|
||||
sub color {
|
||||
my $self = shift;
|
||||
my @colors = @_;
|
||||
my $args = ref($colors[$#colors]) eq "HASH" ? pop @colors : {};
|
||||
if ($self->use_color) {
|
||||
if ($args->{escape}) {
|
||||
return map { "\01" . $self->_resolve_color($_) . "\02" } @colors;
|
||||
} else {
|
||||
return map { $self->_resolve_color($_) } @colors;
|
||||
}
|
||||
} else {
|
||||
return map { "" } @colors;
|
||||
}
|
||||
}
|
||||
|
||||
sub color_theme {
|
||||
return shift->_get_set("color_theme",@_);
|
||||
}
|
||||
|
||||
sub use_color {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined($value)) {
|
||||
$self->{use_color} = $value !~ /^(0|no|never|false)$/i;
|
||||
}
|
||||
return $self->{use_color};
|
||||
}
|
||||
|
||||
|
||||
sub _resolve_color {
|
||||
my $self = shift;
|
||||
my $c = shift;
|
||||
my $color = $self->{color_theme}->{$c};
|
||||
if (exists($self->{color_theme}->{$c})) {
|
||||
return defined($color) ? $color : "";
|
||||
} else {
|
||||
return $c;
|
||||
}
|
||||
}
|
||||
|
||||
# ===========================================================================
|
||||
|
||||
sub _init {
|
||||
my $self = shift;
|
||||
|
||||
# Create shell object
|
||||
my $term = new Term::ShellUI(
|
||||
history_file => "~/.j4psh_history",
|
||||
keep_quotes => 1,
|
||||
);
|
||||
$term->{parser}->{space_none} = "\"'";
|
||||
$self->{term} = $term;
|
||||
my $rl_attribs = $term->{term}->Attribs;
|
||||
#$rl_attribs->{basic_word_break_characters} = " \t\n\\'`@$><;|&{(";
|
||||
$rl_attribs->{completer_word_break_characters} = " \t\n\\";
|
||||
$term->{term}->Attribs($rl_attribs);
|
||||
$term->{term}->ornaments(0);
|
||||
|
||||
my $config = $self->{config};
|
||||
# Set color mode
|
||||
$self->use_color(defined($self->{use_color}) || defined($config->{UseColor}) || "yes");
|
||||
# Init color theme
|
||||
$self->_init_theme($config->{theme});
|
||||
|
||||
my $use_color = "yes";
|
||||
if (exists $self->{args}->{color}) {
|
||||
$use_color = $self->{args}->{color};
|
||||
} elsif (exists $self->{config}->{usecolor}) {
|
||||
$use_color = $self->{config}->{usecolor};
|
||||
}
|
||||
$self->use_color($use_color);
|
||||
|
||||
# Force pipe, quit if less than a screen-full.
|
||||
my @args = (
|
||||
'-f', # force, needed for color output
|
||||
# '-E', # Exit automatically at end of output
|
||||
'-X' # no init
|
||||
);
|
||||
if ($self->use_color) {
|
||||
# Raw control characters
|
||||
push @args,'-R';
|
||||
}
|
||||
if ($ENV{LESS}) {
|
||||
my $l = "";
|
||||
for my $a (@args) {
|
||||
$l .= $a . " " unless $ENV{LESS} =~ /$a/;
|
||||
}
|
||||
if (length($l)) {
|
||||
chop $l;
|
||||
$ENV{LESS} .= " " . $l;
|
||||
}
|
||||
} else {
|
||||
$ENV{LESS} = join " ",@args;
|
||||
}
|
||||
if ($self->{config}->{pager}) {
|
||||
$ENV{PAGER} = $self->{config}->{pager};
|
||||
} elsif (!$ENV{PAGER}) {
|
||||
# Try to find a suitable pager
|
||||
if ($USE_SEARCH_PATH) {
|
||||
for my $p (qw(less more)) {
|
||||
my $pager = searchpath($p, env => 'PATH', exe => 1 );
|
||||
if ($pager) {
|
||||
$ENV{PAGER} = $pager;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
# No searching available, we rely on Term::Clue for finding the proper
|
||||
# pager.
|
||||
}
|
||||
|
||||
if ($ENV{PAGER} && $ENV{PAGER} =~ /more$/) {
|
||||
# If we are using "more", disable coloring
|
||||
$self->use_color("no");
|
||||
}
|
||||
}
|
||||
|
||||
sub default_theme {
|
||||
my $self = shift;
|
||||
# Initial theme
|
||||
my $theme_light = {
|
||||
host => YELLOW,
|
||||
prompt_context => BLUE,
|
||||
prompt_empty => RED,
|
||||
label => YELLOW,
|
||||
domain_name => BLUE,
|
||||
property_key => GREEN,
|
||||
property_value => undef,
|
||||
mbean_name => YELLOW,
|
||||
attribute_name => GREEN,
|
||||
operation_name => YELLOW,
|
||||
stat_val => RED,
|
||||
reset => RESET
|
||||
};
|
||||
my $theme_dark = {
|
||||
host => YELLOW,
|
||||
label => YELLOW,
|
||||
prompt_context => CYAN,
|
||||
prompt_empty => RED,
|
||||
domain_name => YELLOW,
|
||||
property_key => GREEN,
|
||||
property_value => undef,
|
||||
mbean_name => YELLOW,
|
||||
attribute_name => GREEN,
|
||||
operation_name => YELLOW,
|
||||
stat_val => RED,
|
||||
reset => RESET
|
||||
};
|
||||
return $theme_dark;
|
||||
}
|
||||
|
||||
|
||||
sub readline {
|
||||
my $self = shift;
|
||||
my $term = $self->term;
|
||||
return $term->{term}->ReadLine;
|
||||
}
|
||||
|
||||
sub _init_theme {
|
||||
my $self = shift;
|
||||
my $theme_config = shift;
|
||||
my $theme = $self->default_theme;
|
||||
if ($theme_config) {
|
||||
for my $k (keys %$theme_config) {
|
||||
my $c = $theme_config->{$k};
|
||||
$theme->{$k} = $c eq "undef" ? undef : Term::ANSIColor::color($c);
|
||||
}
|
||||
}
|
||||
$self->{color_theme} = $theme;
|
||||
return $theme;
|
||||
}
|
||||
|
||||
sub term_width {
|
||||
return $USE_TERM_SIZE ? (chars())[0] : 120;
|
||||
}
|
||||
|
||||
sub term_height {
|
||||
return $USE_TERM_SIZE ? (chars())[1] : 24;
|
||||
}
|
||||
|
||||
=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;
|
||||
|
||||
465
lib/JMX/Jmx4Perl/Manual.pod
Normal file
465
lib/JMX/Jmx4Perl/Manual.pod
Normal file
@@ -0,0 +1,465 @@
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Manual - Documentation for B<jmx4perl>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
JMX (Java Management Extensions) is the standard management solution in the
|
||||
Java world. Since JDK 1.5 it is available in every Java Virtual Machine and
|
||||
especially JEE application servers use this technology intensively for exposing
|
||||
managable entities. In fact, the popular JEE Server JBoss 4 is based on a JMX
|
||||
kernel.
|
||||
|
||||
For the Perl world, it's not that easy to access JMX MBeans. I<MBean> is the
|
||||
Java term for JMX managed entities. The existing solutions are mostly based on
|
||||
the Java standard JSR-160 (L<http://jcp.org/en/jsr/detail?id=160>), which
|
||||
defines how JMX can be accessed remotely. The problem of JSR-160 with respect
|
||||
to Perl is, that the default communication protocols rely on exchanging
|
||||
serialized Java objects. Hence they require to start a Java Virtual Machine in
|
||||
the one way or other. This has quite some implications concerning installation
|
||||
requirements (you need a Java virtual machine with the proper version
|
||||
installed) and performance (firing up a JVM is not something you get for free)
|
||||
|
||||
The ultimate goal of B<jmx4perl> is to bridge both worlds in the most simplest
|
||||
way. This is done with the I<agent> and I<proxy> based approaches described
|
||||
below. In short, the building blocks of this bridge are based on standards well
|
||||
known and used in both worlds: HTTP and JSON.
|
||||
|
||||
The agent part of jmx4perl can be found at www.jolokia.org. This site also
|
||||
contains all relevant documentation for setting up the agent for various
|
||||
platforms. I.e. the following starting points are of interest, when Jolokia is
|
||||
used with jmx4perl
|
||||
|
||||
=over
|
||||
|
||||
=item L<http://www.jolokia.org/agent.html>
|
||||
|
||||
Overview of all Jolokia agents
|
||||
|
||||
=item L<http://www.jolokia.org/reference/html/index.html>
|
||||
|
||||
Reference manul which contains detailed installation instructions for various
|
||||
platforms.
|
||||
|
||||
=back
|
||||
|
||||
The client part of Jmx4Perl is contained in this library and consist of a set
|
||||
of Perl modules for programatic access as well as a handful of command line
|
||||
tools.
|
||||
|
||||
L<jmx4perl> allows for simple access to JMX MBeans and much more from the
|
||||
command line and is a good starting point.
|
||||
|
||||
=head1 MBean Features
|
||||
|
||||
JMX is a complex specification, which can not be completely revealed in this
|
||||
short documentation. Refer to
|
||||
L<http://java.sun.com/docs/books/tutorial/jmx/index.html> for an introduction
|
||||
to JMX. But in short, one can distinguish three kinds of operational modes:
|
||||
|
||||
=over
|
||||
|
||||
=item Attribute reading and writing
|
||||
|
||||
An MBean can have one or more attributes, which can be read and/or
|
||||
written. jmx4perl knows how to read and write MBean attributes.
|
||||
|
||||
=item Execution of operations
|
||||
|
||||
A MBean can expose certain operations, which can be executed via JMX
|
||||
calls. With jmx4perl, JMX operations can be executed.
|
||||
|
||||
=item Notifications
|
||||
|
||||
Listeners can register to get notified for certain notifications by
|
||||
MBeans. This is not yet supported by jmx4perl and it is technically quite
|
||||
challenging, since HTTP, our transport protocol, is a typical request-response
|
||||
based protocol which is unidirectional by nature. However there are already
|
||||
ideas how to overcome this limitation, but please don't hold your breath. This
|
||||
is on the roadmap, but with very low priority only. Tell me your use case if
|
||||
you want to push it up.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AGENT BASED APPROACH
|
||||
|
||||
An agent based approach requires you to install a small Java Webapplication
|
||||
within your JEE application server. It registers itself locally to the JMX
|
||||
MBeanServer, and listens to HTTP requests whose results are translated into a
|
||||
JSON representation. This reponse can be easily picked up by a Perl module,
|
||||
L<JMX::Jmx4Perl> in our case. This kind of approach differs from the classical
|
||||
approach as suggested by the JMX specification itself.
|
||||
|
||||
This approach works for the following environments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
JEE Servers where a webapplication in the standard WAR format can be deployed.
|
||||
|
||||
=item *
|
||||
|
||||
For the Mule ESB as dedicated Mule agent can be used for exposing JMX to the
|
||||
outside.
|
||||
|
||||
=item *
|
||||
|
||||
Within an OSGi container where the agent gets deployed as an bundle. Two
|
||||
variants are available: One, which requires an installed OSGi HttpService and
|
||||
one, which comes with an embedded HTTP server.
|
||||
|
||||
=item *
|
||||
|
||||
For I<every> Java 6 application running with Sun's (pardon, Oracle's) JVM, a JVM
|
||||
level agent is available which uses the HTTP server embedded in every Sun Java
|
||||
6 JDK.
|
||||
|
||||
=back
|
||||
|
||||
Beside this restriction concerning the runtime environment, this agent based
|
||||
approach has also quite some advantages:
|
||||
|
||||
=head2 Advantages
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
No special startup options for the JEE server are required for exposing JMX
|
||||
informations as it would be the case for exporting JMX via JSR-160 connectors.
|
||||
|
||||
=item *
|
||||
|
||||
No Java installation required on the client for using the agent
|
||||
|
||||
=item *
|
||||
|
||||
No overhead with regard to startup times of a JVM
|
||||
|
||||
=item *
|
||||
|
||||
Since the agent is a standard Java Webapplication it can be secured by
|
||||
standard JEE means like any other Webapplication.
|
||||
|
||||
=item *
|
||||
|
||||
Firewall friendly since all HTTP communication goes over a single port.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Disadvantages
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
The agent can be deployed only to certain Java runtime container (Servlet
|
||||
container, Mule Agent, OSGi container, every Java 6 appliction). But please
|
||||
read on, even when your runtime environment doesn't fit in here. With the
|
||||
I<proxy> approach arbitrary Java applications can be connected to.
|
||||
|
||||
=back
|
||||
|
||||
=head1 PROXY MODE
|
||||
|
||||
Although the I<agent based> is the most simplest way to access JMX, there are
|
||||
circumstances which prevent the deployment of a dedicated agent servlet. This
|
||||
kind of restrictions are mostly politically motivated. For these situations,
|
||||
jmx4perl provides an operational mode known as the I<proxy mode> with which the
|
||||
target platform can be monitored without installing the j4p agent servlet on
|
||||
it. This works by using j4p.war as a JMX Proxy, which translates our
|
||||
JSON/HTTP protocol on the frontside to JSR-160 JMX remote requests on the
|
||||
backend and vice versa.
|
||||
|
||||
A dedicated proxy serlvet server is needed for hosting C<j4p.war>, which supports
|
||||
the I<agent mode> as well as the I<proxy mode>. A lightweight container like
|
||||
Tomcat or Jetty is a perfect choice for this mode. The setup is straight
|
||||
forward:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
Install Jetty (L<http://www.mortbay.org/jetty/>) or Tomcat
|
||||
(L<http://tomcat.apache.org/>)
|
||||
|
||||
=item *
|
||||
|
||||
Deploy C<j4p.war> from the jmx4perl distribution by copying it into the
|
||||
F<webapp> directory.
|
||||
|
||||
=item *
|
||||
|
||||
Enable remote JMX commonicutaion on the target plattform. Please consult the
|
||||
documentation of your Appserver for further details.
|
||||
|
||||
=item *
|
||||
|
||||
Use the C<--target> option for C<jmx4perl> or C<check_jmx4perl> with a JMX
|
||||
service URL (like C<service:jmx:rmi:///jndi/rmi://localhost:9999/jmxrmi>) in
|
||||
order to specify the target server. Use the proxy server's URL as the agent
|
||||
URL:
|
||||
|
||||
jmx4perl http://localhost:8080/jolokia \
|
||||
--target service:jmx:rmi:///jndi/rmi://localhost:9999/jmxrmi list
|
||||
|
||||
|
||||
=back
|
||||
|
||||
Said all this, the proxy mode has some limitations:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
There is no automatic merging of JMX MBeanServers as in the case of the direct
|
||||
mode. Most application servers uses an own MBeanServer in addition to the
|
||||
PlatformMBeanServer (which is always present). Each MBean is registered only in
|
||||
one MBeanServer. The choice, which C<MBeanServer> to use has to be given
|
||||
upfront, usually as a part of the JMX Service URL. But even then (as it is the
|
||||
case for JBoss 5.1) you might run into problem when selecting the proper
|
||||
MBeanServer.
|
||||
|
||||
=item *
|
||||
|
||||
Proxying adds an additional remote layer which causes additional
|
||||
problems. I.e. the complex operations like C<list> might fail in the proxy mode
|
||||
because of serialization issues. E.g. for JBoss it happens that certain
|
||||
MBeanInfo objects requested for the list operation are not serializable. This
|
||||
is a bug of JBoss, but I expect similar limitations for other application
|
||||
servers as well.
|
||||
|
||||
=item *
|
||||
|
||||
Certain workarounds (like the JBoss I<"can not find MXBeans before MBeanInfo has
|
||||
been fetched"> bug) works only in agent mode.
|
||||
|
||||
=item *
|
||||
|
||||
It is astonishingly hard to set up an application server for JSR-160
|
||||
export. And there are even cases (combinations of JDK and AppServer Version)
|
||||
which don't work at all properly (e.g. JDK 1.5 and JBoss 5). For certain
|
||||
application servers, detailed setup instructions are published at
|
||||
http://labs.consol.de/tags/jsr-160/
|
||||
|
||||
=back
|
||||
|
||||
To summarize, the proxy mode should be used only when required. The agent
|
||||
servlet on its own is more powerful than the proxy mode since it eliminates an
|
||||
additional layer, which adds to the overall complexity and performance. Also,
|
||||
minor additional features like merging of MBeanServers are not available in the
|
||||
proxy mode.
|
||||
|
||||
=head1 INSTALLATION
|
||||
|
||||
The Perl part installs as any other module via Module::Build, which
|
||||
you need to have installed. Using
|
||||
|
||||
perl Build.PL
|
||||
./Build
|
||||
./Build test
|
||||
./Build install
|
||||
|
||||
will install the modules.
|
||||
|
||||
In order to download the Jolokia WAR agent into the local directory as
|
||||
jolokia.war, use the following command
|
||||
|
||||
jolokia
|
||||
|
||||
This agent "jolokia.war" needs to be deployed on the JEE Server to
|
||||
monitor. Please consult http://www.jolokia.org/agent.html for more information
|
||||
how to install the agent.
|
||||
|
||||
To test it, you can use L<jmx4perl> with the URL of the deployed
|
||||
agent:
|
||||
|
||||
jmx4perl http://<jeeserver>:<port>/jolokia
|
||||
|
||||
Consult L<jmx4perl> for further details.
|
||||
|
||||
=head1 FEATURES
|
||||
|
||||
=head2 Reading and Writing Attributes
|
||||
|
||||
Jmx4Perl knows how to read any attribute and how to write to certain attributes
|
||||
for whose types are string-to-object conversions are known. Currently, writing
|
||||
of attributes of type String, int, long and boolean is supported. As a special
|
||||
features, Jmx4Perl has the notion of an I<inner path> which is a XPath like
|
||||
expression for pointing into the object returned by a read or write
|
||||
operation.
|
||||
|
||||
=head2 Execution of JMX operations
|
||||
|
||||
It is easy to execute JMX operations, even with arguments. However, they same
|
||||
restrictions for the argument types apply as for writing attributes: There must
|
||||
be an easy way to deserialize an argument from a string representation. The
|
||||
same types as for writing attributes are supported.
|
||||
|
||||
=head2 Autodetection and Product Support
|
||||
|
||||
Jmx4Perl is able to autodectect various application servers. This is done by
|
||||
querying a certain MBean attribute which is unique for this specific
|
||||
product. Many application servers has been tested to work with Jolokia and
|
||||
hence with Jmx4Perl. In fact, Jmx4Perl comes with an integrastion test suite,
|
||||
which is used for integration testing the Jolokia agents. The testing
|
||||
environment is a 64bit Ubuntu 9.04 installation, running in a virtual
|
||||
machine. However, this should not make any difference for another platform, so
|
||||
I'm pretty confident that the application servers from the list above will work
|
||||
with jmx4perl on any OS. Please open a bug at
|
||||
L<http://rt.cpan.org/Public/Bug/Report.html?Queue=jmx4perl> if you encounter
|
||||
any problems.
|
||||
|
||||
Please note, that autodetection is not for free with respect to performance. It
|
||||
takes some considerable time to probe various servers. So, if you have the
|
||||
chance to provide the application server type in advance, you should do
|
||||
this. Said this, please note this is only relevant if you are going to use the
|
||||
aliasing feature described below.
|
||||
|
||||
=head2 Aliasing
|
||||
|
||||
L<JMX::Jmx4Perl::Alias> provides a thin abstraction layer about over the JMX
|
||||
naming scheme so that you can use a single alias value to access the
|
||||
combination (MBean name,attribute) or (MBean name,operation). It also maps the
|
||||
differing naming schemes of different application server to unique names, as
|
||||
far as this is possible. E.g. the alias C<SERVER_VERSION> maps on JBoss to the
|
||||
attribute C<VersionNumber> of MBean C<jboss.system:type=Server>, whereas for
|
||||
Jetty it's mapped to MBean C<org.mortbay:jetty=default>, Attribute C<version>.
|
||||
|
||||
Remember, you can always use the the native JMX naming to access your MBeans
|
||||
without worrying about aliasing at all.
|
||||
|
||||
=head2 History Tracking
|
||||
|
||||
The agent C<jolokia> can be switched into a history tracking mode, where it records
|
||||
the values for C<read>, C<write> and C<exec> operations. You have to call a
|
||||
certain, jmx4perl specific, MBean to turn it on. If switched on each request
|
||||
contains an additional history entry containing the list of historical values
|
||||
along with their timestamps. The history is stored in a list with fixed length
|
||||
so that the oldest value gets removed from the list in case of an overflow.
|
||||
|
||||
=head2 Full featured Nagios plugin C<check_jmx4perl>
|
||||
|
||||
A full functional Nagios plugin called C<check_jmx4perl> is provided in the
|
||||
scripts directory. It can be used to monitor any JMX Mbean's attribute with a
|
||||
numeric value. Thresholds for warning and critical values can be provided in
|
||||
the formats as defined by L<Monitoring::Plugin>. You can use autodetection and
|
||||
aliasing here as well. C<check_jmx4perl> can use relative critical and warning
|
||||
thresholds which refer to some base value taken from another MBean's
|
||||
attribute. An incremental mode can be used to measure the growth rate of
|
||||
certain value (like number of threads). Also, it can monitor the return value
|
||||
of JMX operations as well. C<check_jmx4perl> can use a configuration file with
|
||||
a sophisticated syntax including inheritance, parameterizatiosn and multi-check
|
||||
definitions.
|
||||
|
||||
Please refer to L<check_jmx4perl> for a
|
||||
detailed documentation (which has a 30+ pages manual on its own).
|
||||
|
||||
=head1 WHAT'S NEXT ?
|
||||
|
||||
There are several entry points for jmx4perl. The easiest is to start to play
|
||||
around with L<jmx4perl>. This is a full featured command line tool for
|
||||
exploring the MBeans on your JEE Server.
|
||||
|
||||
If you want to use the Nagios Plugin L<check_jmx4perl> start reading its
|
||||
documentation. A Nagios cookbook is on the roadmap. If you want to restrict
|
||||
access to your JMX MBeanServer read the next chapter in this manual which
|
||||
describes a way to build a custom agent containing a policy file.
|
||||
|
||||
Next, L<JMX::Jmx4Perl> is the entry module. Use this, if you need programmatical
|
||||
access to JMX. Don't forget to have a look into the F<examples> directory which
|
||||
contains some usage examples for L<JMX::Jmx4Perl>
|
||||
|
||||
Of course, you are free to access the agent servlet directly without the usage
|
||||
of the provided module. Even in Java ;-) A description of the request and
|
||||
response format can be found in the protocol description
|
||||
L<JMX::Jmx4Perl::Agent::Protocol>.
|
||||
|
||||
Another resource is the jmx4perl Blog located at L<http://labs.consol.de>. It
|
||||
contains various post about different jmx4perl use case and best practices.
|
||||
Don't forget to add L<http://labs.consol.de/tags/jmx4perl/feed/rss/> to your
|
||||
RSS Feedreader if you want to keep in touch with the latest jmx4perl evolution
|
||||
(there is quite something in the pipeline).
|
||||
|
||||
=head1 ACCESS POLICY
|
||||
|
||||
The deployed agent servlet is quite mighty in the default distribution as you
|
||||
can perform any operation exposed by a MBean via JMX. Of course, you should
|
||||
secure the agent via standard mechanism (e.g via Basic or Digest
|
||||
authentication) to allow only access to certain users. But even then, you might
|
||||
not want your monitoring guys to access the heart of the JEE Server. Therefore,
|
||||
you can restrict access to certain MBeans only by using a so called I<policy>
|
||||
file. You have to repack the agent if you want to use this feature, though. To
|
||||
do this, here's the recipe (assuming the agent is stored as F<jolokia.war> in
|
||||
the current directory):
|
||||
|
||||
=over
|
||||
|
||||
=item 1.
|
||||
|
||||
Download a sample F<jolokia-access.xml> to a local directory:
|
||||
|
||||
jolokia --policy
|
||||
|
||||
=item 2.
|
||||
|
||||
Edit F<jolokia-access.xml> to your needs. In the section C<commands> you can
|
||||
restrict the request types, only those present here are allowed to be
|
||||
called. If the complete C<commands> section is missing, no restriction on a
|
||||
request type is in effect. In the C<mbeans> part you can provide MBeans by name
|
||||
and the allowed attributes and operations. If this section is present, only the
|
||||
MBeans listed can be accessed with the attributes and operations listed. Access
|
||||
to an attribute can be restricted further by giving a C<mode="read"> attribute
|
||||
to the C<attribute> tag in which case the attribute can be accessed
|
||||
read-only. Via the C<remote> section access to certain IP adresses and subnets
|
||||
can be restricted.
|
||||
|
||||
=item 3.
|
||||
|
||||
Repack the agent:
|
||||
|
||||
jolokia repack --policy jolokia.war
|
||||
|
||||
=item 4.
|
||||
|
||||
Deploy the F<jolokia.war> which was created in Step 4.
|
||||
|
||||
=back
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (C) 2009 Roland Huss
|
||||
|
||||
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 L<http://www.gnu.org/licenses/>.
|
||||
|
||||
A commercial license is available as well. You can either apply the GPL or
|
||||
obtain a commercial license for closed source development. Please contact
|
||||
roland@cpan.org for further information.
|
||||
|
||||
=head1 PROFESSIONAL SERVICES
|
||||
|
||||
Just in case you need professional support for jmx4perl (or Nagios or JMX in
|
||||
general), you might want to have a look at
|
||||
L<http://www.consol.com/open-source-monitoring/>. Contact roland.huss@consol.de for
|
||||
further information (or use the contact form at L<http://www.consol.com/contact/>)
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
96
lib/JMX/Jmx4Perl/Nagios/CactiJmx4Perl.pm
Normal file
96
lib/JMX/Jmx4Perl/Nagios/CactiJmx4Perl.pm
Normal file
@@ -0,0 +1,96 @@
|
||||
package JMX::Jmx4Perl::Nagios::CactiJmx4Perl;
|
||||
|
||||
use strict;
|
||||
use base qw(JMX::Jmx4Perl::Nagios::CheckJmx4Perl);
|
||||
use Data::Dumper;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Nagios::CactiJmx4Perl - Module for encapsulating the functionality of
|
||||
L<cacti_jmx4perl>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# One line in check_jmx4perl to rule them all
|
||||
JMX::Jmx4Perl::Nagios::CactiJmx4Perl->new(@ARGV)->execute();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=cut
|
||||
|
||||
sub create_nagios_plugin {
|
||||
my $self = shift;
|
||||
|
||||
my $np = Monitoring::Plugin->
|
||||
new(
|
||||
usage =>
|
||||
"Usage: %s -u <agent-url> [-m <mbean>] [-a <attribute>]\n" .
|
||||
" [--alias <alias>] [--value <shortcut>] [--base <alias/number/mbean>] [--delta <time-base>]\n" .
|
||||
" [--name <name>] [--product <product>]\n".
|
||||
" [--user <user>] [--password <password>] [--proxy <proxy>]\n" .
|
||||
" [--target <target-url>] [--target-user <user>] [--target-password <password>]\n" .
|
||||
" [--legacy-escape]\n" .
|
||||
" [--config <config-file>] [--check <check-name>] [--server <server-alias>] [-v] [--help]\n" .
|
||||
" arg1 arg2 ....",
|
||||
version => $JMX::Jmx4Perl::VERSION,
|
||||
url => "http://www.jmx4perl.org",
|
||||
plugin => "cacti_jmx4perl",
|
||||
license => undef,
|
||||
blurb => "This script can be used as an script for a Cacti Data Input Method",
|
||||
extra => "\n\nYou need to deploy jolokia.war on the target application server or an intermediate proxy.\n" .
|
||||
"Please refer to the documentation for JMX::Jmx4Perl for further details.\n\n" .
|
||||
"For a complete documentation please consult the man page of cacti_jmx4perl or use the option --doc"
|
||||
);
|
||||
$np->shortname(undef);
|
||||
$self->add_common_np_args($np);
|
||||
# Add dummy thresholds to keep Nagios plugin happy
|
||||
$np->set_thresholds(warning => undef, critical => undef);
|
||||
$np->getopts();
|
||||
return $np;
|
||||
}
|
||||
|
||||
sub verify_check {
|
||||
# Not needed
|
||||
}
|
||||
|
||||
sub do_exit {
|
||||
my $self = shift;
|
||||
my $error_stat = shift;
|
||||
my $np = $self->{np};
|
||||
|
||||
my $perf = $np->perfdata;
|
||||
my @res;
|
||||
for my $p (@$perf) {
|
||||
my $label = $p->label;
|
||||
$label =~ s/\s/_/g;
|
||||
push @res,@$perf > 1 ? $label . ":" . $p->value : $p->value;
|
||||
}
|
||||
print join(" ",@res),"\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
|
||||
=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/>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
979
lib/JMX/Jmx4Perl/Nagios/CheckJmx4Perl.pm
Normal file
979
lib/JMX/Jmx4Perl/Nagios/CheckJmx4Perl.pm
Normal file
@@ -0,0 +1,979 @@
|
||||
package JMX::Jmx4Perl::Nagios::CheckJmx4Perl;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use JMX::Jmx4Perl::Nagios::SingleCheck;
|
||||
use JMX::Jmx4Perl::Nagios::MessageHandler;
|
||||
use JMX::Jmx4Perl;
|
||||
use JMX::Jmx4Perl::Request;
|
||||
use JMX::Jmx4Perl::Response;
|
||||
use Data::Dumper;
|
||||
use Monitoring::Plugin;
|
||||
use Monitoring::Plugin::Functions qw(:codes %ERRORS %STATUS_TEXT);
|
||||
use Time::HiRes qw(gettimeofday tv_interval);
|
||||
use Carp;
|
||||
use Text::ParseWords;
|
||||
|
||||
our $AUTOLOAD;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Nagios::CheckJmx4Perl - Module for encapsulating the functionality of
|
||||
L<check_jmx4perl>
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# One line in check_jmx4perl to rule them all
|
||||
JMX::Jmx4Perl::Nagios::CheckJmx4Perl->new()->execute();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The purpose of this module is to encapsulate a single run of L<check_jmx4perl>
|
||||
in a perl object. This allows for C<check_jmx4perl> to run within the embedded
|
||||
Nagios perl interpreter (ePN) wihout interfering with other, potential
|
||||
concurrent, runs of this check. Please refer to L<check_jmx4perl> for
|
||||
documentation on how to use this check. This module is probably I<not> of
|
||||
general interest and serves only the purpose described above.
|
||||
|
||||
Its main task is to set up one ore more L<JMX::Jmx4Perl::Nagios::SingleCheck>
|
||||
objects from command line arguments and optionally from a configuration file.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item $check = new $JMX::Jmx4Perl::Nagios::CheckJmx4Perl()
|
||||
|
||||
Set up a object used for a single check. It will parse the command line
|
||||
arguments and any configuation file given.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = { };
|
||||
bless $self,(ref($class) || $class);
|
||||
$self->{np} = $self->create_nagios_plugin();
|
||||
$self->{cmd_args} = [ @ARGV ];
|
||||
|
||||
$self->_print_doc_and_exit($self->{np}->opts->{doc}) if defined $self->{np}->opts->{doc};
|
||||
$self->_verify_and_initialize();
|
||||
return $self;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 $check->execute()
|
||||
|
||||
Send the JMX request to the server monitored and print out a nagios output.
|
||||
|
||||
=cut
|
||||
|
||||
sub execute {
|
||||
my $self = shift;
|
||||
my $np = $self->{np};
|
||||
eval {
|
||||
# Request
|
||||
my @optional = ();
|
||||
|
||||
my $error_stat = { };
|
||||
my $target_config = $self->target_config;
|
||||
my $jmx = JMX::Jmx4Perl->new(mode => "agent", url => $self->url, user => $self->user,
|
||||
password => $self->password,
|
||||
product => $self->product,
|
||||
proxy => $self->proxy_config,
|
||||
timeout => $np->opts->{timeout} || 180,
|
||||
target => $target_config,
|
||||
# For Jolokia agents < 1.0
|
||||
'legacy-escape' => $self->legacy_escape);
|
||||
my @requests;
|
||||
for my $check (@{$self->{checks}}) {
|
||||
push @requests,@{$check->get_requests($jmx,\@ARGV)};
|
||||
}
|
||||
my $responses = $self->_send_requests($jmx,@requests);
|
||||
#print Dumper($responses);
|
||||
my @extra_requests = ();
|
||||
my $nr_checks = scalar(@{$self->{checks}});
|
||||
if ($nr_checks == 1) {
|
||||
eval {
|
||||
my @r = $self->{checks}->[0]->extract_responses($responses,\@requests,{ target => $target_config });
|
||||
push @extra_requests,@r if @r;
|
||||
};
|
||||
$self->nagios_die($@) if $@;
|
||||
} else {
|
||||
my $i = 1;
|
||||
for my $check (@{$self->{checks}}) {
|
||||
# A check can consume more than one response
|
||||
my $prefix = $self->_multi_check_prefix($check,$i++,$nr_checks);
|
||||
eval {
|
||||
my @r = $check->extract_responses($responses,\@requests,
|
||||
{
|
||||
target => $target_config,
|
||||
prefix => $prefix,
|
||||
error_stat => $error_stat
|
||||
});
|
||||
push @extra_requests,@r if @r;
|
||||
};
|
||||
if ($@) {
|
||||
my $txt = $@;
|
||||
$txt =~ s/^(.*?)\n.*$/$1/s;
|
||||
my $code = $np->opts->{'unknown-is-critical'} ? CRITICAL : UNKNOWN;
|
||||
$check->update_error_stats($error_stat,$code);
|
||||
$prefix =~ s/\%c/$STATUS_TEXT{$code}/g;
|
||||
my $msg_handler = $np->{msg_handler} || $np;
|
||||
$msg_handler->add_message($code,$prefix . $txt);
|
||||
}
|
||||
}
|
||||
}
|
||||
# Send extra requests, e.g. for switching on the history
|
||||
if (@extra_requests) {
|
||||
$self->_send_requests($jmx,@extra_requests);
|
||||
}
|
||||
|
||||
# Different outputs for multi checks/single checks
|
||||
$self->do_exit($error_stat);
|
||||
};
|
||||
if ($@) {
|
||||
# p1.pl, the executing script of the embedded nagios perl interpreter
|
||||
# uses this tag to catch an exit code of a plugin. We rethrow this
|
||||
# exception if we detect this pattern.
|
||||
if ($@ !~ /^ExitTrap:/) {
|
||||
$self->nagios_die("Error: $@");
|
||||
} else {
|
||||
die $@;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head1 $check->exit()
|
||||
|
||||
Write out result and exit. This method can be overridden to provide a custom
|
||||
output, which can be extracted from NagiosPlugin object.
|
||||
|
||||
=cut
|
||||
|
||||
sub do_exit {
|
||||
my $self = shift;
|
||||
my $error_stat = shift;
|
||||
my $np = $self->{np};
|
||||
|
||||
my $msg_handler = $np->{msg_handler} || $np;
|
||||
my ($code,$message) = $msg_handler->check_messages(join => "\n", join_all => "\n");
|
||||
($code,$message) = $self->_prepare_multicheck_message($np,$code,$message,$error_stat) if scalar(@{$self->{checks}}) > 1;
|
||||
|
||||
$np->nagios_exit($code, $message);
|
||||
}
|
||||
|
||||
sub _prepare_multicheck_message {
|
||||
my $self = shift;
|
||||
my $np = shift;
|
||||
my $code = shift;
|
||||
my $message = shift;
|
||||
my $error_stat = shift;
|
||||
|
||||
my $summary;
|
||||
my $labels = $self->{multi_check_labels} || {};
|
||||
my $nr_checks = scalar(@{$self->{checks}});
|
||||
$code = $self->_check_for_UNKNOWN($error_stat,$code);
|
||||
if ($code eq OK) {
|
||||
$summary = $self->_format_multicheck_ok_summary($labels->{summary_ok} ||
|
||||
"All %n checks OK",$nr_checks);
|
||||
} else {
|
||||
$summary = $self->_format_multicheck_failure_summary($labels->{summary_failure} ||
|
||||
"%e of %n checks failed [%d]",
|
||||
$nr_checks,
|
||||
$error_stat);
|
||||
}
|
||||
return ($code,$summary . "\n" . $message);
|
||||
}
|
||||
|
||||
# UNKNOWN shadows everything else
|
||||
sub _check_for_UNKNOWN {
|
||||
my $self = shift;
|
||||
my $error_stat = shift;
|
||||
my $code = shift;
|
||||
return $error_stat->{UNKNOWN} && scalar(@$error_stat->{UNKNOWN}) ? UNKNOWN : $code;
|
||||
}
|
||||
|
||||
sub _format_multicheck_ok_summary {
|
||||
my $self = shift;
|
||||
my $format = shift;
|
||||
my $nr_checks = shift;
|
||||
my $ret = $format;
|
||||
$ret =~ s/\%n/$nr_checks/g;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub _format_multicheck_failure_summary {
|
||||
my $self = shift;
|
||||
my $format = shift;
|
||||
my $nr_checks = shift;
|
||||
my $error_stat = shift;
|
||||
|
||||
my $ret = $format;
|
||||
|
||||
my $details = "";
|
||||
my $total_errors = 0;
|
||||
for my $code (UNKNOWN,CRITICAL,WARNING) {
|
||||
if (my $errs = $error_stat->{$code}) {
|
||||
$details .= scalar(@$errs) . " " . $STATUS_TEXT{$code} . " (" . join (",",@$errs) . "), ";
|
||||
$total_errors += scalar(@$errs);
|
||||
}
|
||||
}
|
||||
if ($total_errors > 0) {
|
||||
# Cut off extra chars at the end
|
||||
$details = substr($details,0,-2);
|
||||
}
|
||||
|
||||
$ret =~ s/\%d/$details/g;
|
||||
$ret =~ s/\%e/$total_errors/g;
|
||||
$ret =~ s/\%n/$nr_checks/g;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# Create a formatted prefix for multicheck output
|
||||
sub _multi_check_prefix {
|
||||
my $self = shift;
|
||||
my $check = shift;
|
||||
my $idx = shift;
|
||||
my $max = shift;
|
||||
|
||||
my $c = $check->{config};
|
||||
|
||||
my $l = length($max);
|
||||
|
||||
return sprintf("[%$l.${l}s] %%c ",$idx)
|
||||
if (defined($c->{multicheckprefix}) && !length($c->{multicheckprefix}));
|
||||
|
||||
my $label = $c->{multicheckprefix} || $c->{name} || $c->{key} || "";
|
||||
return sprintf("[%$l.${l}s] %%c %s: ",$idx,$label);
|
||||
}
|
||||
|
||||
|
||||
# Send the requests via the build up agent
|
||||
sub _send_requests {
|
||||
my ($self,$jmx,@requests) = @_;
|
||||
my $o = $self->{opts};
|
||||
|
||||
my $start_time;
|
||||
if ($o->verbose) {
|
||||
# TODO: Print summary of request (GET vs POST)
|
||||
if ($self->user) {
|
||||
print "Remote User: ",$o->user,"\n";
|
||||
}
|
||||
$start_time = [gettimeofday];
|
||||
}
|
||||
# Detangle request for direct method calls and JMX requests to call:
|
||||
my $req_map = $self->_detangle_requests(\@requests);
|
||||
my @responses = ();
|
||||
|
||||
$self->_execute_scripts(\@responses,$req_map);
|
||||
$self->_execute_requests(\@responses,$req_map,$jmx);
|
||||
|
||||
if ($o->verbose) {
|
||||
print "Result fetched in ",tv_interval($start_time) * 1000," ms:\n";
|
||||
print Dumper(\@responses);
|
||||
}
|
||||
return \@responses;
|
||||
}
|
||||
|
||||
# Split up request for code-requests (i.e. scripts given in the configuration)
|
||||
# and 'real' requests. Remember the index, too so that the response can be
|
||||
# weave together
|
||||
sub _detangle_requests {
|
||||
my $self = shift;
|
||||
my $requests = shift;
|
||||
my $req_map = {};
|
||||
my $idx = 0;
|
||||
for my $r (@$requests) {
|
||||
push @{$req_map->{ref($r) eq "CODE" ? "code" : "request"}},[$r,$idx];
|
||||
$idx++;
|
||||
}
|
||||
return $req_map;
|
||||
}
|
||||
|
||||
# Execute subrefs created out of scripts. Put it in the right place of the
|
||||
# result array according to the remembered index
|
||||
sub _execute_scripts {
|
||||
my $self = shift;
|
||||
my $responses = shift;
|
||||
my $req_map = shift;
|
||||
for my $e (@{$req_map->{"code"}}) {
|
||||
# Will die on error which will bubble up
|
||||
$responses->[$e->[1]] = &{$e->[0]}();;
|
||||
}
|
||||
}
|
||||
|
||||
# Execute requests and put it in the received responses in the right place for
|
||||
# the returned array. The index has been extracted beforehand and stored in the
|
||||
# given req_map
|
||||
sub _execute_requests {
|
||||
my $self = shift;
|
||||
my $responses = shift;
|
||||
my $req_map = shift;
|
||||
my $jmx = shift;
|
||||
|
||||
# Call remote JMX and weave in
|
||||
my $reqs2send = $req_map->{"request"};
|
||||
if ($reqs2send) {
|
||||
my @resp_received = $jmx->request(map { $_->[0] } @$reqs2send);
|
||||
for my $r (@$reqs2send) {
|
||||
$responses->[$r->[1]] = shift @resp_received;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Print online manual and exit (somewhat crude, I know)
|
||||
sub _print_doc_and_exit {
|
||||
my $self = shift;
|
||||
my $section = shift;
|
||||
if (!eval "require Pod::Usage; Pod::Usage->import(qw(pod2usage)); 1;") {
|
||||
print "Please install Pod::Usage for creating the online help\n";
|
||||
exit 1;
|
||||
}
|
||||
if ($section) {
|
||||
my %sects = (
|
||||
tutorial => "TUTORIAL",
|
||||
reference => "REFERENCE",
|
||||
options => "COMMAND LINE",
|
||||
config => "CONFIGURATION",
|
||||
);
|
||||
my $real_section = $sects{lc $section};
|
||||
if ($real_section) {
|
||||
pod2usage(-verbose => 99, -sections => $real_section );
|
||||
} else {
|
||||
print "Unknown documentation section '$section' (known: ",join (",",sort keys %sects),")\n";
|
||||
exit 1;
|
||||
}
|
||||
} else {
|
||||
pod2usage(-verbose => 99);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Initialize this object and validate the mandatory parameters (obtained from
|
||||
# the command line or a configuration file). It will also build up
|
||||
# one or more SingleCheck which are later on sent as a bulk request to
|
||||
# the server.
|
||||
sub _verify_and_initialize {
|
||||
my $self = shift;
|
||||
my $np = $self->{np};
|
||||
my $o = $np->opts;
|
||||
|
||||
$self->{opts} = $self->{np}->opts;
|
||||
|
||||
# Fetch configuration
|
||||
my $config = $self->_get_config($o->config);
|
||||
# Now, if a specific check is given, extract it, too.
|
||||
my $check_configs;
|
||||
#print Dumper($config);
|
||||
$check_configs = $self->_extract_checks($config,$o->check);
|
||||
#print Dumper($check_configs);
|
||||
if ($check_configs) {
|
||||
for my $c (@$check_configs) {
|
||||
my $s_c = new JMX::Jmx4Perl::Nagios::SingleCheck($np,$c);
|
||||
push @{$self->{checks}},$s_c;
|
||||
}
|
||||
} else {
|
||||
$self->{checks} = [ new JMX::Jmx4Perl::Nagios::SingleCheck($np) ];
|
||||
}
|
||||
# If a server name is given, we use that for the connection parameters
|
||||
if ($o->server) {
|
||||
$self->{server_config} = $config->get_server_config($o->server)
|
||||
|| $self->nagios_die("No server configuration for " . $o->server . " found");
|
||||
}
|
||||
|
||||
# Sanity checks
|
||||
$self->nagios_die("No Server URL given") unless $self->url;
|
||||
|
||||
for my $check (@{$self->{checks}}) {
|
||||
my $name = $check->name ? " [Check: " . $check->name . "]" : "";
|
||||
$self->nagios_die("An MBean name and a attribute/operation must be provided " . $name)
|
||||
if ((!$check->mbean || (!$check->attribute && !$check->operation)) && !$check->alias && !$check->value && !$check->script);
|
||||
}
|
||||
}
|
||||
|
||||
# Extract one or more check configurations which can be
|
||||
# simple <Check>s or <MultiCheck>s
|
||||
sub _extract_checks {
|
||||
my $self = shift;
|
||||
my $config = shift;
|
||||
my $check = shift;
|
||||
|
||||
my $np = $self->{np};
|
||||
if ($check) {
|
||||
$self->nagios_die("No configuration given") unless $config;
|
||||
$self->nagios_die("No checks defined in configuration") unless $config->{check};
|
||||
|
||||
my $check_configs;
|
||||
unless ($config->{check}->{$check}) {
|
||||
$check_configs = $self->_resolve_multicheck($config,$check,$self->{cmd_args});
|
||||
$self->_retrieve_mc_summary_label($config,$check);
|
||||
} else {
|
||||
my $check_config = $config->{check}->{$check};
|
||||
$check_configs = ref($check_config) eq "ARRAY" ? $check_config : [ $check_config ];
|
||||
$check_configs->[0]->{key} = $check;
|
||||
}
|
||||
$self->nagios_die("No check configuration with name " . $check . " found") unless (@{$check_configs});
|
||||
|
||||
#print Dumper($check_configs);
|
||||
|
||||
# Resolve parent values
|
||||
for my $c (@{$check_configs}) {
|
||||
#print "[A] ",Dumper($c);
|
||||
$self->_resolve_check_config($c,$config,$self->{cmd_args});
|
||||
|
||||
#print "[B] ",Dumper($c);
|
||||
# Finally, resolve any left over place holders
|
||||
for my $k (keys(%$c)) {
|
||||
$c->{$k} = $self->_replace_placeholder($c->{$k},undef) unless ref($c->{$k});
|
||||
}
|
||||
#print "[C] ",Dumper($c);
|
||||
}
|
||||
return $check_configs;
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# Resolve a multicheck configuration (<MultiCheck>)
|
||||
sub _resolve_multicheck {
|
||||
my $self = shift;
|
||||
my $config = shift;
|
||||
my $check = shift;
|
||||
my $args = shift;
|
||||
my $np = $self->{np};
|
||||
my $multi_checks = $config->{multicheck};
|
||||
my $check_config = [];
|
||||
if ($multi_checks) {
|
||||
my $m_check = $multi_checks->{$check};
|
||||
if ($m_check) {
|
||||
# Resolve all checks
|
||||
my $c_names = [];
|
||||
for my $type( qw(check multicheck)) {
|
||||
if ($m_check->{$type}) {
|
||||
push @$c_names, ref($m_check->{$type}) eq "ARRAY" ? @{$m_check->{$type}} : $m_check->{$type};
|
||||
}
|
||||
}
|
||||
for my $name (@$c_names) {
|
||||
my ($c_name,$c_args) = $self->_parse_check_ref($name);
|
||||
my $args_merged = $self->_merge_multicheck_args($c_args,$args);
|
||||
$self->nagios_die("Unknown check '" . $c_name . "' for multi check " . $check)
|
||||
unless defined($config->{check}->{$c_name}) or defined($multi_checks->{$c_name});
|
||||
if ($config->{check}->{$c_name}) {
|
||||
# We need a copy of the check hash to avoid mangling it up
|
||||
# if it is referenced multiple times
|
||||
my $check = { %{$config->{check}->{$c_name}} };
|
||||
$check->{key} = $c_name;
|
||||
$check->{args} = $args_merged;
|
||||
push @{$check_config},$check;
|
||||
} else {
|
||||
# It's a multi check referenced via <Check> or <MultiCheck> ....
|
||||
push @{$check_config},@{$self->_resolve_multicheck($config,$c_name,$args_merged)};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return $check_config;
|
||||
}
|
||||
|
||||
sub _retrieve_mc_summary_label {
|
||||
my $self = shift;
|
||||
my $config = shift;
|
||||
my $check = shift;
|
||||
|
||||
my $multi_checks = $config->{multicheck};
|
||||
if ($multi_checks) {
|
||||
my $m_check = $multi_checks->{$check};
|
||||
if ($m_check && ($m_check->{summaryok} || $m_check->{summaryfailure})) {
|
||||
my $mc_labels =
|
||||
$self->{multi_check_labels} = {
|
||||
summary_ok => $m_check->{summaryok},
|
||||
summary_failure => $m_check->{summaryfailure}
|
||||
};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _merge_multicheck_args {
|
||||
my $self = shift;
|
||||
my $check_params = shift;
|
||||
my $args = shift;
|
||||
if (!$args || !$check_params) {
|
||||
return $check_params;
|
||||
}
|
||||
my $ret = [ @$check_params ]; # Copy it over
|
||||
for my $i (0 .. $#$check_params) {
|
||||
if ($check_params->[$i] =~ /^\$(\d+)$/) {
|
||||
my $j = $1;
|
||||
if ($j <= $#$args) {
|
||||
$ret->[$i] = $args->[$j];
|
||||
next;
|
||||
}
|
||||
# Nothing to replace
|
||||
$ret->[$i] = $check_params->[$i];
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# Resolve a singe <Check> configuration
|
||||
sub _resolve_check_config {
|
||||
my $self = shift;
|
||||
my $check = shift;
|
||||
my $config = shift;
|
||||
# Args can come from the outside, but also as part of a multicheck (stored
|
||||
# in $check->{args})
|
||||
my $args = $check->{args} && @{$check->{args}} ? $check->{args} : shift;
|
||||
my $np = $self->{np};
|
||||
if ($check->{use}) {
|
||||
# Resolve parents
|
||||
my $parents = ref($check->{use}) eq "ARRAY" ? $check->{use} : [ $check->{use} ];
|
||||
my $parent_merged = {};
|
||||
for my $p (@$parents) {
|
||||
my ($p_name,$p_args) = $self->_parse_check_ref($p);
|
||||
$self->nagios_die("Unknown parent check '" . $p_name . "' for check '" .
|
||||
($check->{key} ? $check->{key} : $check->{name}) . "'")
|
||||
unless $config->{check}->{$p_name};
|
||||
# Clone it to avoid side effects when replacing checks inline
|
||||
my $p_check = { %{$config->{check}->{$p_name}} };
|
||||
$p_check->{key} = $p_name;
|
||||
#print "::::: ",Dumper($p_check,$p_args);
|
||||
|
||||
$self->_resolve_check_config($p_check,$config,$p_args);
|
||||
|
||||
#$self->_replace_args($p_check,$config,$p_args);
|
||||
$parent_merged->{$_} = $p_check->{$_} for keys %$p_check;
|
||||
}
|
||||
# Replace inherited values
|
||||
for my $k (keys %$parent_merged) {
|
||||
my $parent_val = defined($parent_merged->{$k}) ? $parent_merged->{$k} : "";
|
||||
if (defined($check->{$k})) {
|
||||
$check->{$k} =~ s/\$BASE/$parent_val/g;
|
||||
} else {
|
||||
$check->{$k} = $parent_val;
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->_replace_args($check,$config,$args);
|
||||
return $check;
|
||||
}
|
||||
|
||||
# Replace argument placeholders with a given list of arguments
|
||||
sub _replace_args {
|
||||
my $self = shift;
|
||||
my $check = shift;
|
||||
my $config = shift;
|
||||
my $args = shift;
|
||||
for my $k (keys(%$check)) {
|
||||
next if $k =~ /^(key|args)$/; # Internal keys
|
||||
$check->{$k} =
|
||||
$self->_replace_placeholder($check->{$k},$args)
|
||||
if ($args && @$args && !ref($check->{$k}));
|
||||
}
|
||||
}
|
||||
|
||||
sub _replace_placeholder {
|
||||
my $self = shift;
|
||||
my $val = shift;
|
||||
my $args = shift;
|
||||
my $index = defined($args) ? join "|",0 ... $#$args : "\\d+";
|
||||
|
||||
my $regexp_s = <<'EOP';
|
||||
^(.*?) # Start containing no args
|
||||
|
||||
\$( # Variable starts with '$'
|
||||
($index) | # $0 without default value
|
||||
\{\s*($index)\s* # ${0:12300} with default value
|
||||
(?: :([^\}]+) )*\} # ?: --> clustering group, optional (${0} is also ok)
|
||||
)
|
||||
|
||||
(.*|$) # The rest which will get parsed next
|
||||
EOP
|
||||
$regexp_s =~ s/\$index/$index/g;
|
||||
my $regexp = qr/$regexp_s/sx;
|
||||
die "Cannot create placeholder regexp" if $@;
|
||||
my $rest = $val;
|
||||
my $ret = "";
|
||||
while (defined($rest) && length($rest) && $rest =~ $regexp) {
|
||||
# $1: start with no placeholder
|
||||
# $2: literal variable as it is defined
|
||||
# $3: variable name (0,1,2,3,...)
|
||||
# $4: same as $3, but either $3 or $4 is defined
|
||||
# $5: default value (if any)
|
||||
# $6: rest which is processed next in the loop
|
||||
my $start = defined($1) ? $1 : "";
|
||||
my $orig_val = '$' . $2;
|
||||
my $i = defined($3) ? $3 : $4;
|
||||
my $default = $5;
|
||||
my $end = defined($6) ? $6 : "";
|
||||
$default =~ s/^\s*(.*)+?\s*$/$1/ if $default; # Trim whitespace
|
||||
#print Dumper({start => $start, orig => $orig_val,end => $end, default=> $default, rest => $rest, i => $i});
|
||||
if (defined($args)) {
|
||||
my $repl = $args->[$i];
|
||||
if (defined($repl)) {
|
||||
if ($repl =~ /^\$(\d+)$/) {
|
||||
my $new_index = $1;
|
||||
#print "============== $val $new_index\n";
|
||||
# Val is a placeholder itself
|
||||
if (defined($default)) {
|
||||
$ret .= $start . '${' . $new_index . ':' . $default . '}';
|
||||
} else {
|
||||
$ret .= $start . '$' . $new_index;
|
||||
}
|
||||
} else {
|
||||
$ret .= $start . $repl;
|
||||
}
|
||||
} else {
|
||||
$ret .= $start . $orig_val;
|
||||
}
|
||||
} else {
|
||||
# We have to replace any left over placeholder either with its
|
||||
# default value or with an empty value
|
||||
if (defined($default)) {
|
||||
$ret .= $start . $default;
|
||||
} elsif (length($start) || length($end)) {
|
||||
$ret .= $start;
|
||||
} else {
|
||||
if (!length($ret)) {
|
||||
# No default value, nothing else for this value. We
|
||||
# consider it undefined
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
}
|
||||
$rest = $end;
|
||||
#print "... $ret$rest\n";
|
||||
}
|
||||
return $ret . (defined($rest) ? $rest : "");
|
||||
}
|
||||
|
||||
# Split up a 'Use' parent config reference, including possibly arguments
|
||||
sub _parse_check_ref {
|
||||
my $self = shift;
|
||||
my $check_ref = shift;
|
||||
if ($check_ref =~/^\s*(.+?)\((.*)\)\s*$/) {
|
||||
my $name = $1;
|
||||
my $args_s = $2;
|
||||
my $args = [ parse_line('\s*,\s*',0,$args_s) ];
|
||||
return ($name,$args);
|
||||
} else {
|
||||
return $check_ref;
|
||||
}
|
||||
}
|
||||
|
||||
# Get the configuration as a hash
|
||||
sub _get_config {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
my $np = $self->{np};
|
||||
$self->nagios_die("No configuration file " . $path . " found")
|
||||
if ($path && ! -e $path);
|
||||
return new JMX::Jmx4Perl::Config($path);
|
||||
}
|
||||
|
||||
# The global server config part
|
||||
sub _server_config {
|
||||
return shift->{server_config};
|
||||
}
|
||||
|
||||
# Create the nagios plugin used for preparing the nagios output
|
||||
sub create_nagios_plugin {
|
||||
my $self = shift;
|
||||
my $np = Monitoring::Plugin->
|
||||
new(
|
||||
usage =>
|
||||
"Usage: %s -u <agent-url> -m <mbean> -a <attribute> -c <threshold critical> -w <threshold warning>\n" .
|
||||
" [--alias <alias>] [--value <shortcut>] [--base <alias/number/mbean>] [--delta <time-base>]\n" .
|
||||
" [--name <perf-data label>] [--label <output-label>] [--product <product>]\n".
|
||||
" [--user <user>] [--password <password>] [--proxy <proxy>]\n" .
|
||||
" [--target <target-url>] [--target-user <user>] [--target-password <password>]\n" .
|
||||
" [--legacy-escape]\n" .
|
||||
" [--config <config-file>] [--check <check-name>] [--server <server-alias>] [-v] [--help]\n" .
|
||||
" arg1 arg2 ....",
|
||||
version => $JMX::Jmx4Perl::VERSION,
|
||||
url => "http://www.jmx4perl.org",
|
||||
plugin => "check_jmx4perl",
|
||||
blurb => "This plugin checks for JMX attribute values on a remote Java application server",
|
||||
extra => "\n\nYou need to deploy jolokia.war on the target application server or an intermediate proxy.\n" .
|
||||
"Please refer to the documentation for JMX::Jmx4Perl for further details.\n\n" .
|
||||
"For a complete documentation please consult the man page of check_jmx4perl or use the option --doc"
|
||||
);
|
||||
$np->shortname(undef);
|
||||
$self->add_common_np_args($np);
|
||||
$self->add_nagios_np_args($np);
|
||||
$np->{msg_handler} = new JMX::Jmx4Perl::Nagios::MessageHandler();
|
||||
$np->getopts();
|
||||
return $np;
|
||||
}
|
||||
|
||||
sub add_common_np_args {
|
||||
my $self = shift;
|
||||
my $np = shift;
|
||||
|
||||
$np->add_arg(
|
||||
spec => "url|u=s",
|
||||
help => "URL to agent web application (e.g. http://server:8080/jolokia/)",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "product=s",
|
||||
help => "Name of app server product. (e.g. \"jboss\")",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "alias=s",
|
||||
help => "Alias name for attribte (e.g. \"MEMORY_HEAP_USED\")",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "mbean|m=s",
|
||||
help => "MBean name (e.g. \"java.lang:type=Memory\")",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "attribute|a=s",
|
||||
help => "Attribute name (e.g. \"HeapMemoryUsage\")",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "operation|o=s",
|
||||
help => "Operation to execute",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "value=s",
|
||||
help => "Shortcut for specifying mbean/attribute/path. Slashes within names must be escaped with \\",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "delta|d:s",
|
||||
help => "Switches on incremental mode. Optional argument are seconds used for normalizing.",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "path|p=s",
|
||||
help => "Inner path for extracting a single value from a complex attribute or return value (e.g. \"used\")",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "target=s",
|
||||
help => "JSR-160 Service URL specifing the target server"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "target-user=s",
|
||||
help => "Username to use for JSR-160 connection (if --target is set)"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "target-password=s",
|
||||
help => "Password to use for JSR-160 connection (if --target is set)"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "proxy=s",
|
||||
help => "Proxy to use"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "user=s",
|
||||
help => "User for HTTP authentication"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "password=s",
|
||||
help => "Password for HTTP authentication"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "name|n=s",
|
||||
help => "Name to use for output. Optional, by default a standard value based on the MBean ".
|
||||
"and attribute will be used"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "legacy-escape!",
|
||||
help => "Use legacy escape mechanism for Jolokia agents < 1.0"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "config=s",
|
||||
help => "Path to configuration file. Default: ~/.j4p"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "server=s",
|
||||
help => "Symbolic name of server url to use, which needs to be configured in the configuration file"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "check=s",
|
||||
help => "Name of a check configuration as defined in the configuration file"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "method=s",
|
||||
help => "HTTP method to use. Either \"get\" or \"post\""
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "doc:s",
|
||||
help => "Print the documentation of check_jmx4perl, optionally specifying the section (tutorial, args, config)"
|
||||
);
|
||||
}
|
||||
|
||||
sub add_nagios_np_args {
|
||||
my $self = shift;
|
||||
my $np = shift;
|
||||
|
||||
$np->add_arg(
|
||||
spec => "base|base-alias|b=s",
|
||||
help => "Base name, which when given, interprets critical and warning values as relative in the range 0 .. 100%. Must be given in the form mbean/attribute/path",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "base-mbean=s",
|
||||
help => "Base MBean name, interprets critical and warning values as relative in the range 0 .. 100%. Requires a base-attribute, too",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "base-attribute=s",
|
||||
help => "Base attribute for a relative check. Used together with base-mbean",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "base-path=s",
|
||||
help => "Base path for relatie checks, where this path is used on the base attribute's value",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "unit=s",
|
||||
help => "Unit of measurement of the data retreived. Recognized values are [B|KB|MN|GB|TB] for memory values and [us|ms|s|m|h|d] for time values"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "null=s",
|
||||
help => "Value which should be used in case of a null return value of an operation or attribute. Is \"null\" by default"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "string",
|
||||
help => "Force string comparison for critical and warning checks"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "numeric",
|
||||
help => "Force numeric comparison for critical and warning checks"
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "critical|c=s",
|
||||
help => "Critical Threshold for value. " .
|
||||
"See http://nagiosplug.sourceforge.net/developer-guidelines.html#THRESHOLDFORMAT " .
|
||||
"for the threshold format.",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "warning|w=s",
|
||||
help => "Warning Threshold for value.",
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "label|l=s",
|
||||
help => "Label to be used for printing out the result of the check. Placeholders can be used."
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "perfdata=s",
|
||||
help => "Whether performance data should be omitted, which are included by default."
|
||||
);
|
||||
$np->add_arg(
|
||||
spec => "unknown-is-critical",
|
||||
help => "Map UNKNOWN errors to errors with a CRITICAL status"
|
||||
);
|
||||
}
|
||||
|
||||
# Access to configuration informations
|
||||
# Known config options (key: cmd line arguments, values: keys in config);
|
||||
my $SERVER_CONFIG_KEYS = {
|
||||
"url" => "url",
|
||||
"user" => "user",
|
||||
"password" => "password",
|
||||
"product" => "product",
|
||||
"legacy_escape" => "legacyconfig"
|
||||
};
|
||||
|
||||
# Get target configuration or undef if no jmx-proxy mode
|
||||
# is used
|
||||
sub target_config {
|
||||
return shift->_target_or_proxy_config("target","target-user","target-password");
|
||||
}
|
||||
|
||||
# Get proxy configuration or undef if no proxy configuration
|
||||
# is used
|
||||
sub proxy_config {
|
||||
return shift->_target_or_proxy_config("proxy","proxy-user","proxy-password");
|
||||
}
|
||||
|
||||
sub _target_or_proxy_config {
|
||||
my $self = shift;
|
||||
|
||||
my $main_key = shift;
|
||||
my $user_opt = shift;
|
||||
my $password_opt = shift;
|
||||
|
||||
my $np = $self->{np};
|
||||
my $opts = $np->opts;
|
||||
my $server_config = $self->_server_config;
|
||||
if ($opts->{$main_key}) {
|
||||
# Use configuration from the command line:
|
||||
return {
|
||||
url => $opts->{$main_key},
|
||||
user => $opts->{$user_opt},
|
||||
password => $opts->{$password_opt}
|
||||
}
|
||||
} elsif ($server_config && $server_config->{$main_key}) {
|
||||
# Use configuration directly from the server definition:
|
||||
return $server_config->{$main_key}
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# Autoloading is used to fetch the proper connection parameters
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
my $np = $self->{np};
|
||||
my $name = $AUTOLOAD;
|
||||
$name =~ s/.*://; # strip fully-qualified portion
|
||||
my $opts_name = $name;
|
||||
$opts_name =~ s/_/-/;
|
||||
|
||||
if ($SERVER_CONFIG_KEYS->{$name}) {
|
||||
return $np->opts->{$opts_name} if $np->opts->{$opts_name};
|
||||
my $c = $SERVER_CONFIG_KEYS->{$name};
|
||||
if ($c) {
|
||||
my @parts = split "/",$c;
|
||||
my $h = $self->_server_config ||
|
||||
return undef;
|
||||
while (@parts) {
|
||||
my $p = shift @parts;
|
||||
return undef unless $h->{$p};
|
||||
$h = $h->{$p};
|
||||
return $h unless @parts;
|
||||
}
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$self->nagios_die("No config attribute \"" . $name . "\" known");
|
||||
}
|
||||
}
|
||||
|
||||
sub nagios_die {
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
|
||||
my $np = $self->{np};
|
||||
$np->nagios_die(join("",@args),$np->opts->{'unknown-is-critical'} ? CRITICAL : UNKNOWN)
|
||||
}
|
||||
|
||||
# Declared here to avoid AUTOLOAD confusions
|
||||
sub DESTROY {
|
||||
|
||||
}
|
||||
|
||||
=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/>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
60
lib/JMX/Jmx4Perl/Nagios/MessageHandler.pm
Normal file
60
lib/JMX/Jmx4Perl/Nagios/MessageHandler.pm
Normal file
@@ -0,0 +1,60 @@
|
||||
package JMX::Jmx4Perl::Nagios::MessageHandler;
|
||||
|
||||
use Monitoring::Plugin::Functions qw(:codes %ERRORS %STATUS_TEXT);
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Nagios::MessageHandler - Handling Nagios exit message (one or
|
||||
many)
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
messages => {}
|
||||
};
|
||||
bless $self,(ref($class) || $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub add_message {
|
||||
my $self = shift;
|
||||
my ($code,@messages) = @_;
|
||||
|
||||
die "Invalid error code '$code'\n"
|
||||
unless defined($ERRORS{uc $code}) || defined($STATUS_TEXT{$code});
|
||||
|
||||
# Store messages using strings rather than numeric codes
|
||||
$code = $STATUS_TEXT{$code} if $STATUS_TEXT{$code};
|
||||
$code = lc $code;
|
||||
|
||||
$self->{messages}->{$code} = [] unless $self->{messages}->{$code};
|
||||
push @{$self->{messages}->{$code}}, @messages;
|
||||
}
|
||||
|
||||
sub check_messages {
|
||||
my $self = shift;
|
||||
my %arg = @_;
|
||||
|
||||
for my $code (qw(critical warning ok unknown)) {
|
||||
$arg{$code} = $self->{messages}->{$code} || [];
|
||||
}
|
||||
|
||||
my $code = OK;
|
||||
$code ||= UNKNOWN if @{$arg{unknown}};
|
||||
$code ||= CRITICAL if @{$arg{critical}};
|
||||
$code ||= WARNING if @{$arg{warning}};
|
||||
|
||||
my $message = join( "\n",
|
||||
map { @$_ ? join( "\n", @$_) : () }
|
||||
$arg{unknown},
|
||||
$arg{critical},
|
||||
$arg{warning},
|
||||
$arg{ok} ? (ref $arg{ok} ? $arg{ok} : [ $arg{ok} ]) : []
|
||||
);
|
||||
return ($code, $message);
|
||||
}
|
||||
|
||||
1;
|
||||
821
lib/JMX/Jmx4Perl/Nagios/SingleCheck.pm
Normal file
821
lib/JMX/Jmx4Perl/Nagios/SingleCheck.pm
Normal file
@@ -0,0 +1,821 @@
|
||||
package JMX::Jmx4Perl::Nagios::SingleCheck;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use JMX::Jmx4Perl;
|
||||
use JMX::Jmx4Perl::Request;
|
||||
use JMX::Jmx4Perl::Response;
|
||||
use JMX::Jmx4Perl::Alias;
|
||||
use Data::Dumper;
|
||||
use Monitoring::Plugin;
|
||||
use Monitoring::Plugin::Functions qw(:codes %STATUS_TEXT);
|
||||
use Carp;
|
||||
use Scalar::Util qw(looks_like_number);
|
||||
use URI::Escape;
|
||||
use Text::ParseWords;
|
||||
use JSON;
|
||||
|
||||
our $AUTOLOAD;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Nagios::SingleCheck - A single nagios check
|
||||
|
||||
This is an package used internally by
|
||||
L<JMX::Jmx4Perl::Nagios::CheckJmx4Perl>. It encapsulates the configuration for
|
||||
single checks, which can be combined to a bulk JMX-Request so only a single
|
||||
server turnaround is used to obtain multiple checks results at once.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item $single_check = new $JMX::Jmx4Perl::Nagios::SingleCheck($nagios_plugin,$check_config)
|
||||
|
||||
Construct a new single check from a given L<Monitoring::Plugin> object
|
||||
C<$nagios_plugin> and a parsed check configuration $check_config, which is a
|
||||
hash.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $np = shift || die "No Nagios Plugin given";
|
||||
my $config = shift;
|
||||
my $self = {
|
||||
np => $np,
|
||||
config => $config
|
||||
};
|
||||
bless $self,(ref($class) || $class);
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $requests = $single_check->get_requests($jmx,$args)
|
||||
|
||||
Called to obtain an arrayref of L<JMX::Jmx4Perl::Request> objects which should
|
||||
be send to the server agent. C<$jmx> ist the L<JMX::Jmx4Perl> agent, C<$args>
|
||||
are additonal arguments used for exec-operations,
|
||||
|
||||
Multiple request object are returned e.g. if a relative check has to be
|
||||
performed in order to get the base value as well.
|
||||
|
||||
The returned array can contain coderefs which should be executed directly and
|
||||
its return value should be used in order to perfoorm the check.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_requests {
|
||||
my $self = shift;
|
||||
my $jmx = shift;
|
||||
my $args = shift;
|
||||
# If a script is given, extract a subref and return it
|
||||
return [ $self->_extract_script_as_subref($jmx) ] if $self->script;
|
||||
|
||||
my $do_read = $self->attribute || $self->value;
|
||||
my $do_exec = $self->operation;
|
||||
if ($self->alias) {
|
||||
my $alias = JMX::Jmx4Perl::Alias->by_name($self->alias);
|
||||
die "No alias '",$self->alias," known" unless $alias;
|
||||
$do_read = $alias->type eq "attribute";
|
||||
}
|
||||
my @requests = ();
|
||||
my $request;
|
||||
if ($do_read) {
|
||||
$request = JMX::Jmx4Perl::Request->new(READ,$self->_prepare_read_args($jmx));
|
||||
} elsif ($do_exec) {
|
||||
$request = JMX::Jmx4Perl::Request->new(EXEC,$self->_prepare_exec_args($jmx,@$args));
|
||||
} else {
|
||||
die "Neither an attribute/value, an operation or a script given";
|
||||
}
|
||||
my $method = $self->{np}->opts->{method} || $self->{config}->{method};
|
||||
if ($method) {
|
||||
$request->method($method);
|
||||
}
|
||||
push @requests,$request;
|
||||
|
||||
if ($self->base || $self->base_mbean) {
|
||||
if (!looks_like_number($self->base)) {
|
||||
# It looks like a number, so we will use the base literally
|
||||
my $alias;
|
||||
|
||||
if ($self->base) {
|
||||
$alias = JMX::Jmx4Perl::Alias->by_name($self->base);
|
||||
}
|
||||
if ($alias) {
|
||||
push @requests,new JMX::Jmx4Perl::Request(READ,$jmx->resolve_alias($self->base));
|
||||
} else {
|
||||
my ($mbean,$attr,$path) = $self->base_mbean ?
|
||||
($self->base_mbean, $self->base_attribute, $self->base_path) :
|
||||
$self->_split_attr_spec($self->base);
|
||||
die "No MBean given in base name ",$self->base unless $mbean;
|
||||
die "No Attribute given in base name ",$self->base unless $attr;
|
||||
|
||||
$mbean = URI::Escape::uri_unescape($mbean);
|
||||
$attr = URI::Escape::uri_unescape($attr);
|
||||
$path = URI::Escape::uri_unescape($path) if $path;
|
||||
push @requests,new JMX::Jmx4Perl::Request(READ,$mbean,$attr,$path);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return \@requests;
|
||||
}
|
||||
|
||||
# Create a subref where all params from the outside are available as closures.
|
||||
sub _extract_script_as_subref {
|
||||
my $self = shift;
|
||||
my $jmx = shift;
|
||||
my $script = $self->script || die "No script given";
|
||||
my $full_script = <<"EOT";
|
||||
sub {
|
||||
my \$j4p = shift;
|
||||
return sub {
|
||||
$script
|
||||
}
|
||||
}
|
||||
EOT
|
||||
#print $full_script,"\n";
|
||||
my $sub = eval $full_script;
|
||||
die "Cannot eval script for check ",$self->name,": $@" if $@;
|
||||
return &$sub($jmx);
|
||||
}
|
||||
|
||||
=item $single_check->exract_responses($responses,$requests,$target)
|
||||
|
||||
Extract L<JMX::Jmx4Perl::Response> objects and add the deducted results to
|
||||
the nagios plugin (which was given at construction time).
|
||||
|
||||
C<$responses> is an arrayref to the returned responses, C<$requests> is an
|
||||
arrayref to the original requests. Any response consumed from C<$requests>
|
||||
should be removed from the array, as well as the corresponding request.
|
||||
The requests/responses for this single request are always a the beginning of
|
||||
the arrays.
|
||||
|
||||
C<$target> is an optional target configuration if the request was used in
|
||||
target proxy mode.
|
||||
|
||||
=cut
|
||||
|
||||
sub extract_responses {
|
||||
my $self = shift;
|
||||
my $responses = shift;
|
||||
my $requests = shift;
|
||||
my $opts = shift || {};
|
||||
my $np = $self->{np};
|
||||
my $msg_handler = $np->{msg_handler} || $np;
|
||||
|
||||
# Get response/request pair
|
||||
my $resp = shift @{$responses};
|
||||
my $request = shift @{$requests};
|
||||
#print Dumper($resp);
|
||||
my @extra_requests = ();
|
||||
my $value;
|
||||
my $script_mode = undef;
|
||||
if (ref($request) eq "CODE") {
|
||||
# It's a script, so the 'response' is already the value
|
||||
$script_mode = 1;
|
||||
$value = $resp;
|
||||
} else {
|
||||
$self->_verify_response($request,$resp);
|
||||
$value = $self->_extract_value($request,$resp);
|
||||
}
|
||||
# Delta handling
|
||||
my $delta = $self->delta;
|
||||
if (defined($delta) && !$script_mode) {
|
||||
$value = $self->_delta_value($request,$resp,$delta);
|
||||
unless (defined($value)) {
|
||||
push @extra_requests,$self->_switch_on_history($request,$opts->{target});
|
||||
$value = 0;
|
||||
}
|
||||
}
|
||||
|
||||
# Normalize value
|
||||
my ($value_conv,$unit) = $self->_normalize_value($value);
|
||||
my $label = $self->_get_name(cleanup => 1);
|
||||
if ( ($self->base || $self->base_mbean) && !$script_mode) {
|
||||
# Calc relative value
|
||||
my $base_value = $self->_base_value($self->base,$responses,$requests);
|
||||
my $rel_value = sprintf "%2.2f",$base_value ? (int((($value / $base_value) * 10000) + 0.5) / 100) : 0;
|
||||
|
||||
# Performance data. Convert to absolute values before
|
||||
if ($self->_include_perf_data) {
|
||||
if ($self->perfdata && $self->perfdata =~ /^\s*\%\s*/) {
|
||||
$np->add_perfdata(label => $label, value => $rel_value, uom => '%',
|
||||
critical => $self->critical, warning => $self->warning);
|
||||
} else {
|
||||
my ($critical,$warning) = $self->_convert_relative_to_absolute($base_value,$self->critical,$self->warning);
|
||||
$np->add_perfdata(label => $label,value => $value,
|
||||
critical => $critical,warning => $warning,
|
||||
min => 0,max => $base_value,
|
||||
$self->unit ? (uom => $self->unit) : ());
|
||||
}
|
||||
}
|
||||
# Do the real check.
|
||||
my ($code,$mode) = $self->_check_threshold($rel_value);
|
||||
# For Multichecks, we remember the label of a currently failed check
|
||||
$self->update_error_stats($opts->{error_stat},$code) unless $code == OK;
|
||||
my ($base_conv,$base_unit) = $self->_normalize_value($base_value);
|
||||
$msg_handler->add_message($code,$self->_exit_message(code => $code,mode => $mode,rel_value => $rel_value,
|
||||
value => $value_conv, unit => $unit, base => $base_conv,
|
||||
base_unit => $base_unit, prefix => $opts->{prefix}));
|
||||
} else {
|
||||
# Performance data
|
||||
$value = $self->_sanitize_value($value);
|
||||
if ($self->_include_perf_data) {
|
||||
$np->add_perfdata(label => $label,
|
||||
critical => $self->critical, warning => $self->warning,
|
||||
value => $value,$self->unit ? (uom => $self->unit) : ());
|
||||
}
|
||||
|
||||
# Do the real check.
|
||||
my ($code,$mode) = $self->_check_threshold($value);
|
||||
$self->update_error_stats($opts->{error_stat},$code) unless $code == OK;
|
||||
$msg_handler->add_message($code,$self->_exit_message(code => $code,mode => $mode,value => $value_conv, unit => $unit,
|
||||
prefix => $opts->{prefix}));
|
||||
}
|
||||
return @extra_requests;
|
||||
}
|
||||
|
||||
sub _include_perf_data {
|
||||
my $self = shift;
|
||||
# No perf dara for string based checks by default
|
||||
my $default = not defined($self->string);
|
||||
# If 'PerfData' is set explicitely to false/off/no/0 then no perfdata
|
||||
# will be included
|
||||
return $default unless defined($self->perfdata);
|
||||
return $self->perfdata !~ /^\s*(false|off|no|0)\s*$/i;
|
||||
}
|
||||
|
||||
sub update_error_stats {
|
||||
my $self = shift;
|
||||
my $error_stat = shift || return;
|
||||
my $code = shift;
|
||||
|
||||
my $label = $self->{config}->{name} || $self->{config}->{key};
|
||||
if ($label) {
|
||||
my $arr = $error_stat->{$code} || [];
|
||||
push @$arr,$label;
|
||||
$error_stat->{$code} = $arr;
|
||||
}
|
||||
}
|
||||
|
||||
# Extract a single value, which is different, if the request was a pattern read
|
||||
# request
|
||||
sub _extract_value {
|
||||
my $self = shift;
|
||||
my $req = shift;
|
||||
my $resp = shift;
|
||||
if ($req->get('type') eq READ && $req->is_mbean_pattern) {
|
||||
return $self->_extract_value_from_pattern_request($resp->value);
|
||||
} else {
|
||||
return $self->_null_safe_value($resp->value);
|
||||
}
|
||||
}
|
||||
|
||||
sub _null_safe_value {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined($value)) {
|
||||
if (JSON::is_bool($value)) {
|
||||
return $value ? "true" : "false";
|
||||
} elsif (ref($value) && $self->string) {
|
||||
# We can deal with complex values withing string comparison
|
||||
if (ref($value) eq "ARRAY") {
|
||||
return join ",",@{$value};
|
||||
} else {
|
||||
return Dumper($value);
|
||||
}
|
||||
} else {
|
||||
return $value;
|
||||
}
|
||||
} else {
|
||||
# Our null value
|
||||
return defined($self->null) ? $self->null : "null";
|
||||
}
|
||||
}
|
||||
|
||||
sub _extract_value_from_pattern_request {
|
||||
my $self = shift;
|
||||
my $val = shift;
|
||||
my $np = $self->{np};
|
||||
$self->_die("Pattern request does not result in a proper return format: " . Dumper($val))
|
||||
if (ref($val) ne "HASH");
|
||||
$self->_die("More than one MBean found for a pattern request: " . Dumper([keys %$val])) if keys %$val != 1;
|
||||
my $attr_val = (values(%$val))[0];
|
||||
$self->_die("Invalid response for pattern match: " . Dumper($attr_val)) unless ref($attr_val) eq "HASH";
|
||||
$self->_die("Only a single attribute can be used. Given: " . Dumper([keys %$attr_val])) if keys %$attr_val != 1;
|
||||
return $self->_null_safe_value((values(%$attr_val))[0]);
|
||||
}
|
||||
|
||||
sub _delta_value {
|
||||
my ($self,$req,$resp,$delta) = @_;
|
||||
|
||||
my $history = $resp->history;
|
||||
if (!$history) {
|
||||
# No delta on the first run
|
||||
return undef;
|
||||
} else {
|
||||
my $hist_val;
|
||||
if ($req->is_mbean_pattern) {
|
||||
$hist_val = $self->_extract_value_from_pattern_request($history);
|
||||
} else {
|
||||
$hist_val = $history;
|
||||
}
|
||||
if (!@$hist_val) {
|
||||
# Can happen in some scenarios when requesting the first history entry,
|
||||
# we return 0 here
|
||||
return 0;
|
||||
}
|
||||
my $old_value = $hist_val->[0]->{value};
|
||||
my $old_time = $hist_val->[0]->{timestamp};
|
||||
my $value = $self->_extract_value($req,$resp);
|
||||
if ($delta) {
|
||||
# Time average
|
||||
my $time_delta = $resp->timestamp - $old_time;
|
||||
return (($value - $old_value) / ($time_delta ? $time_delta : 1)) * $delta;
|
||||
} else {
|
||||
return $value - $old_value;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _switch_on_history {
|
||||
my ($self,$orig_request,$target) = @_;
|
||||
my ($mbean,$operation) = ("jolokia:type=Config","setHistoryEntriesForAttribute");
|
||||
# Set history to 1 (we need only the last)
|
||||
return new JMX::Jmx4Perl::Request
|
||||
(EXEC,$mbean,$operation,
|
||||
$orig_request->get("mbean"),$orig_request->get("attribute"),$orig_request->get("path"),
|
||||
$target ? $target->{url} : undef,1,{target => undef});
|
||||
}
|
||||
|
||||
|
||||
sub _base_value {
|
||||
my $self = shift;
|
||||
my $np = $self->{np};
|
||||
my $name = shift;
|
||||
my $responses = shift;
|
||||
my $requests = shift;
|
||||
|
||||
if (looks_like_number($name)) {
|
||||
# It looks like a number, so we suppose its the base value itself
|
||||
return $name;
|
||||
}
|
||||
my $resp = shift @{$responses};
|
||||
my $req = shift @{$requests};
|
||||
$self->_die($resp->{error}) if $resp->{error};
|
||||
#print Dumper($req,$resp);
|
||||
return $self->_extract_value($req,$resp);
|
||||
}
|
||||
|
||||
# Normalize value if a unit-of-measurement is given.
|
||||
|
||||
# Units and how to convert from one level to the next
|
||||
my @UNITS = ([ qw(ns us ms s m h d) ],[qw(B KB MB GB TB)]);
|
||||
my %UNITS =
|
||||
(
|
||||
ns => 1,
|
||||
us => 10**3,
|
||||
ms => 10**3,
|
||||
s => 10**3,
|
||||
m => 60,
|
||||
h => 60,
|
||||
d => 24,
|
||||
|
||||
B => 1,
|
||||
KB => 2**10,
|
||||
MB => 2**10,
|
||||
GB => 2**10,
|
||||
TB => 2**10
|
||||
);
|
||||
|
||||
sub _normalize_value {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
my $unit = shift || $self->unit || return ($value,undef);
|
||||
|
||||
for my $units (@UNITS) {
|
||||
for my $i (0 .. $#{$units}) {
|
||||
next unless $units->[$i] eq $unit;
|
||||
my $ret = $value;
|
||||
my $u = $unit;
|
||||
if (abs($ret) > 1) {
|
||||
# Go up the scale ...
|
||||
return ($value,$unit) if $i == $#{$units};
|
||||
for my $j ($i+1 .. $#{$units}) {
|
||||
if (abs($ret / $UNITS{$units->[$j]}) >= 1) {
|
||||
$ret /= $UNITS{$units->[$j]};
|
||||
$u = $units->[$j];
|
||||
} else {
|
||||
return ($ret,$u);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
# Go down the scale ...
|
||||
return ($value,$unit) if $i == 0;
|
||||
for my $j (reverse(0 .. $i-1)) {
|
||||
if ($ret < 1) {
|
||||
$ret *= $UNITS{$units->[$j+1]};
|
||||
$u = $units->[$j];
|
||||
} else {
|
||||
return ($ret,$u);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
return ($ret,$u);
|
||||
}
|
||||
}
|
||||
die "Unknown unit '$unit' for value $value";
|
||||
}
|
||||
|
||||
sub _sanitize_value {
|
||||
my ($self,$value) = @_;
|
||||
if ($value =~ /\de/i) {
|
||||
$value = sprintf("%f", $value);
|
||||
}
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub _verify_response {
|
||||
my ($self,$req,$resp) = @_;
|
||||
my $np = $self->{np};
|
||||
if ($resp->is_error) {
|
||||
my $extra = "";
|
||||
if ($np->opts->{verbose}) {
|
||||
my $stacktrace = $resp->stacktrace;
|
||||
$extra = ref($stacktrace) eq "ARRAY" ? join "\n",@$stacktrace : $stacktrace if $stacktrace;
|
||||
}
|
||||
$self->_die("Error: ".$resp->status." ".$resp->error_text.$extra);
|
||||
}
|
||||
|
||||
if (!$req->is_mbean_pattern && (ref($resp->value) && !$self->string) && !JSON::is_bool($resp->value)) {
|
||||
$self->_die("Response value is a " . ref($resp->value) .
|
||||
", not a plain value. Did you forget a --path parameter ?". " Value: " .
|
||||
Dumper($resp->value));
|
||||
}
|
||||
}
|
||||
|
||||
sub _get_name {
|
||||
my $self = shift;
|
||||
my $args = { @_ };
|
||||
my $name = $args->{name};
|
||||
if (!$name) {
|
||||
if ($self->name) {
|
||||
$name = $self->name;
|
||||
} else {
|
||||
# Default name, tried to be generated from various parts
|
||||
if ($self->alias) {
|
||||
$name = "[".$self->alias.($self->path ? "," . $self->path : "") ."]";
|
||||
} else {
|
||||
my $val = $self->value;
|
||||
if ($val) {
|
||||
$name = "[" . $val . "]";
|
||||
} else {
|
||||
my $a_or_o = $self->attribute || $self->operation || "";
|
||||
my $p = $self->path ? "," . $self->path : "";
|
||||
$name = "[" . $self->mbean . "," . $a_or_o . $p . "]";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($args->{cleanup}) {
|
||||
# Enable this when '=' gets forbidden
|
||||
$name =~ s/=/#/g;
|
||||
}
|
||||
# Prepare label for usage with Monitoring::Plugin, which will blindly
|
||||
# add quotes if a space is contained in the label.
|
||||
# We are doing the escape of quotes ourself here
|
||||
$name =~ s/'/''/g;
|
||||
return $name;
|
||||
}
|
||||
|
||||
sub _prepare_read_args {
|
||||
my $self = shift;
|
||||
my $np = $self->{np};
|
||||
my $jmx = shift;
|
||||
|
||||
if ($self->alias) {
|
||||
my @req_args = $jmx->resolve_alias($self->alias);
|
||||
$self->_die("Cannot resolve attribute alias ",$self->alias()) unless @req_args > 0;
|
||||
if ($self->path) {
|
||||
@req_args == 2 ? $req_args[2] = $self->path : $req_args[2] .= "/" . $self->path;
|
||||
}
|
||||
return @req_args;
|
||||
} elsif ($self->value) {
|
||||
return $self->_split_attr_spec($self->value);
|
||||
} else {
|
||||
return ($self->mbean,$self->attribute,$self->path);
|
||||
}
|
||||
}
|
||||
|
||||
sub _prepare_exec_args {
|
||||
my $self = shift;
|
||||
my $np = $self->{np};
|
||||
my $jmx = shift;
|
||||
|
||||
#print Dumper($self->{config});
|
||||
# Merge CLI arguments and arguments from the configuration,
|
||||
# with CLI arguments taking precedence
|
||||
my @cli_args = @_;
|
||||
my $config_args = $self->{config}->{argument};
|
||||
|
||||
$config_args = [ $config_args ] if defined($config_args) && ref($config_args) ne "ARRAY";
|
||||
my @args = ();
|
||||
if ($config_args) {
|
||||
my @c_args = (@$config_args);
|
||||
while (@cli_args || @c_args) {
|
||||
my $cli_arg = shift @cli_args;
|
||||
my $config_arg = shift @c_args;
|
||||
push @args, defined($cli_arg) ? $cli_arg : $config_arg;
|
||||
}
|
||||
} else {
|
||||
@args = @cli_args;
|
||||
}
|
||||
if ($self->alias) {
|
||||
my @req_args = $jmx->resolve_alias($self->alias);
|
||||
$self->_die("Cannot resolve operation alias ",$self->alias()) unless @req_args >= 2;
|
||||
return (@req_args,@args);
|
||||
} else {
|
||||
return ($self->mbean,$self->operation,@args);
|
||||
}
|
||||
}
|
||||
|
||||
sub _split_attr_spec {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my @ret = ();
|
||||
# Text:ParseWords is used for split on "/" taking into account
|
||||
# quoting and escaping
|
||||
for my $p (parse_line("/",1,$name)) {
|
||||
# We need to 'unescape' things ourselves
|
||||
# since we want quotes to remain in the names (using '0'
|
||||
# above would kill those quotes, too).
|
||||
$p =~ s|\\(.)|$1|sg;
|
||||
push @ret,$p;
|
||||
}
|
||||
return (shift(@ret),shift(@ret),@ret ? join("/",@ret) : undef);
|
||||
}
|
||||
|
||||
sub _check_threshold {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
my $np = $self->{np};
|
||||
my $numeric_check;
|
||||
if ($self->numeric || $self->string) {
|
||||
$numeric_check = $self->numeric ? 1 : 0;
|
||||
} else {
|
||||
$numeric_check = looks_like_number($value);
|
||||
}
|
||||
if ($numeric_check) {
|
||||
# Verify numeric thresholds
|
||||
my @ths =
|
||||
(
|
||||
defined($self->critical) ? (critical => $self->critical) : (),
|
||||
defined($self->warning) ? (warning => $self->warning) : ()
|
||||
);
|
||||
#print Dumper({check => $value,@ths});
|
||||
return (@ths ? $np->check_threshold(check => $value,@ths) : OK,"numeric");
|
||||
} else {
|
||||
return
|
||||
($self->_check_string_threshold($value,CRITICAL,$self->critical) ||
|
||||
$self->_check_string_threshold($value,WARNING,$self->warning) ||
|
||||
OK,
|
||||
$value =~ /^true|false$/i ? "boolean" : "string");
|
||||
}
|
||||
}
|
||||
|
||||
sub _check_string_threshold {
|
||||
my $self = shift;
|
||||
my ($value,$level,$check_value) = @_;
|
||||
return undef unless $check_value;
|
||||
if ($check_value =~ m|^\s*qr(.)(.*)\1\s*$|) {
|
||||
return $value =~ m/$2/ ? $level : undef;
|
||||
}
|
||||
if ($check_value =~ s/^\!//) {
|
||||
return $value ne $check_value ? $level : undef;
|
||||
} else {
|
||||
return $value eq $check_value ? $level : undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub _convert_relative_to_absolute {
|
||||
my $self = shift;
|
||||
my ($base_value,@to_convert) = @_;
|
||||
my @ret = ();
|
||||
for my $v (@to_convert) {
|
||||
$v =~ s|([\d\.]+)|($1 / 100) * $base_value|eg if $v;
|
||||
push @ret,$v;
|
||||
}
|
||||
return @ret;
|
||||
}
|
||||
|
||||
# Prepare an exit message depending on the result of
|
||||
# the check itself. Quite evolved, you can overwrite this always via '--label'.
|
||||
sub _exit_message {
|
||||
my $self = shift;
|
||||
my $args = { @_ };
|
||||
# Custom label has precedence
|
||||
return $self->_format_label($self->label,$args) if $self->label;
|
||||
|
||||
my $code = $args->{code};
|
||||
my $mode = $args->{mode};
|
||||
if ($code == CRITICAL || $code == WARNING) {
|
||||
if ($self->base || $self->base_mbean) {
|
||||
return $self->_format_label
|
||||
('%n : Threshold \'%t\' failed for value %.2r% ('. &_placeholder($args,"v") .' %u / '.
|
||||
&_placeholder($args,"b") . ' %u)',$args);
|
||||
} else {
|
||||
if ($mode ne "numeric") {
|
||||
return $self->_format_label('%n : \'%v\' matches threshold \'%t\'',$args);
|
||||
} else {
|
||||
return $self->_format_label
|
||||
('%n : Threshold \'%t\' failed for value '.&_placeholder($args,"v").' %u',$args);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if ($self->base || $self->base_mbean) {
|
||||
return $self->_format_label('%n : In range %.2r% ('. &_placeholder($args,"v") .' %u / '.
|
||||
&_placeholder($args,"b") . ' %w)',$args);
|
||||
} else {
|
||||
if ($mode ne "numeric") {
|
||||
return $self->_format_label('%n : \'%v\' as expected',$args);
|
||||
} else {
|
||||
return $self->_format_label('%n : Value '.&_placeholder($args,"v").' %u in range',$args);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
sub _placeholder {
|
||||
my ($args,$c) = @_;
|
||||
my $val;
|
||||
if ($c eq "v") {
|
||||
$val = $args->{value};
|
||||
} else {
|
||||
$val = $args->{base};
|
||||
}
|
||||
return ($val =~ /\./ ? "%.2" : "%") . $c;
|
||||
}
|
||||
|
||||
sub _format_label {
|
||||
my $self = shift;
|
||||
my $label = shift;
|
||||
my $args = shift;
|
||||
# %r : relative value (as percent)
|
||||
# %q : relative value (as floating point)
|
||||
# %v : value
|
||||
# %f : value as floating point
|
||||
# %u : unit
|
||||
# %b : base value
|
||||
# %w : base unit
|
||||
# %t : threshold failed ("" for OK or UNKNOWN)
|
||||
# %c : code ("OK", "WARNING", "CRITICAL", "UNKNOWN")
|
||||
# %d : delta
|
||||
#
|
||||
my @parts = split /(\%[\w\.\-]*\w)/,$label;
|
||||
my $ret = "";
|
||||
foreach my $p (@parts) {
|
||||
if ($p =~ /^(\%[\w\.\-]*)(\w)$/) {
|
||||
my ($format,$what) = ($1,$2);
|
||||
if ($what eq "r" || $what eq "q") {
|
||||
my $val = $args->{rel_value} || 0;
|
||||
$val = $what eq "r" ? $val : $val / 100;
|
||||
$ret .= sprintf $format . "f",$val;
|
||||
} elsif ($what eq "b") {
|
||||
$ret .= sprintf $format . &_format_char($args->{base}),($args->{base} || 0);
|
||||
} elsif ($what eq "u" || $what eq "w") {
|
||||
$ret .= sprintf $format . "s",($what eq "u" ? $args->{unit} : $args->{base_unit}) || "";
|
||||
$ret =~ s/\s$//;
|
||||
} elsif ($what eq "f") {
|
||||
$ret .= sprintf $format . "f",$args->{value};
|
||||
} elsif ($what eq "v") {
|
||||
$ret .= &_format_value($format,$args->{mode},$args->{value});
|
||||
} elsif ($what eq "t") {
|
||||
my $code = $args->{code};
|
||||
my $val = $code == CRITICAL ? $self->critical : ($code == WARNING ? $self->warning : "");
|
||||
$ret .= sprintf $format . "s",defined($val) ? $val : "";
|
||||
} elsif ($what eq "c") {
|
||||
$ret .= sprintf $format . "s",$STATUS_TEXT{$args->{code}};
|
||||
} elsif ($what eq "n") {
|
||||
$ret .= sprintf $format . "s",$self->_get_name();
|
||||
} elsif ($what eq "d") {
|
||||
$ret .= sprintf $format . "d",$self->delta;
|
||||
} elsif ($what eq "y") {
|
||||
$ret .= &_format_value($format,$args->{mode},$self->warning);
|
||||
} elsif ($what eq "z") {
|
||||
$ret .= &_format_value($format,$args->{mode},$self->critical);
|
||||
}
|
||||
} else {
|
||||
$ret .= $p;
|
||||
}
|
||||
}
|
||||
if ($args->{prefix}) {
|
||||
my $prefix = $args->{prefix};
|
||||
$prefix =~ s/\%c/$STATUS_TEXT{$args->{code}}/g;
|
||||
return $prefix . $ret;
|
||||
} else {
|
||||
return $ret;
|
||||
}
|
||||
}
|
||||
|
||||
sub _format_value {
|
||||
my $format = shift;
|
||||
my $mode = shift;
|
||||
my $value = shift;
|
||||
if ($mode ne "numeric") {
|
||||
return sprintf $format . "s",$value;
|
||||
} else {
|
||||
return sprintf $format . &_format_char($value),$value;
|
||||
}
|
||||
}
|
||||
sub _format_char {
|
||||
my $val = shift;
|
||||
$val =~ /\./ ? "f" : "d";
|
||||
}
|
||||
|
||||
sub _die {
|
||||
my $self = shift;
|
||||
my $msg = join("",@_);
|
||||
die $msg,"\n";
|
||||
}
|
||||
|
||||
my $CHECK_CONFIG_KEYS = {
|
||||
"critical" => "critical",
|
||||
"warning" => "warning",
|
||||
"mbean" => "mbean",
|
||||
"attribute" => "attribute",
|
||||
"operation" => "operation",
|
||||
"alias" => "alias",
|
||||
"path" => "path",
|
||||
"delta" => "delta",
|
||||
"name" => "name",
|
||||
"base" => "base",
|
||||
"base-mbean" => "basembean",
|
||||
"base-attribute" => "baseattribute",
|
||||
"base-path" => "basepath",
|
||||
"unit" => "unit",
|
||||
"numeric" => "numeric",
|
||||
"string" => "string",
|
||||
"label" => "label",
|
||||
"perfdata" => "perfdata",
|
||||
"value" => "value",
|
||||
"null" => "null",
|
||||
"script" => "script"
|
||||
};
|
||||
|
||||
|
||||
# Get the proper configuration values
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
my $np = $self->{np};
|
||||
my $name = $AUTOLOAD;
|
||||
$name =~ s/.*://; # strip fully-qualified portion
|
||||
$name =~ s/_/-/g;
|
||||
|
||||
if ($CHECK_CONFIG_KEYS->{$name}) {
|
||||
return $np->opts->{$name} if defined($np->opts->{$name});
|
||||
if ($self->{config}) {
|
||||
return $self->{config}->{$CHECK_CONFIG_KEYS->{$name}};
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
} else {
|
||||
$self->_die("No config attribute \"" . $name . "\" known");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# To keep autoload happy
|
||||
sub DESTROY {
|
||||
|
||||
}
|
||||
|
||||
=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/>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
79
lib/JMX/Jmx4Perl/Product/ActiveMQ.pm
Normal file
79
lib/JMX/Jmx4Perl/Product/ActiveMQ.pm
Normal file
@@ -0,0 +1,79 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::ActiveMQ;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
use Data::Dumper;
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::ActiveMQ - Handler for Jonas
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support for ActiveMQ
|
||||
(L<http://activemq.apache.org/>) which works with the JVM Agent provided for
|
||||
Sun JDK 6 based applications
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "activemq";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "ActiveMQ";
|
||||
}
|
||||
|
||||
sub vendor {
|
||||
return "Apache";
|
||||
}
|
||||
|
||||
sub version {
|
||||
# No way to detect version until yet.
|
||||
return "";
|
||||
}
|
||||
sub order {
|
||||
return 200;
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return sub {
|
||||
my $self = shift;
|
||||
my $j4p = $self->{jmx4perl};
|
||||
my $ret = $j4p->search("org.apache.activemq:*");
|
||||
#print Dumper($ret);
|
||||
return $ret;
|
||||
};
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
647
lib/JMX/Jmx4Perl/Product/BaseHandler.pm
Normal file
647
lib/JMX/Jmx4Perl/Product/BaseHandler.pm
Normal file
@@ -0,0 +1,647 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package JMX::Jmx4Perl::Product::BaseHandler;
|
||||
|
||||
use strict;
|
||||
use JMX::Jmx4Perl::Request;
|
||||
use JMX::Jmx4Perl::Request;
|
||||
use JMX::Jmx4Perl::Alias;
|
||||
use Carp qw(croak);
|
||||
use Data::Dumper;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::BaseHandler - Base package for product specific handler
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This base class is used for specific L<JMX::Jmx4Perl::Product> in order
|
||||
to provide some common functionality. Extends this package if you want to hook
|
||||
in your own product handler. Any module below
|
||||
C<JMX::Jmx4Perl::Product::> will be automatically picked up by
|
||||
L<JMX::Jmx4Perl>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=item $handler = JMX::Jmx4Perl::Product::MyHandler->new($jmx4perl);
|
||||
|
||||
Constructor which requires a L<JMX::Jmx4Perl> object as single argument. If you
|
||||
overwrite this method in a subclass, dont forget to call C<SUPER::new>, but
|
||||
normally there is little need for overwritting new.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $jmx4perl = shift || croak "No associated JMX::Jmx4Perl given";
|
||||
my $self = {
|
||||
jmx4perl => $jmx4perl
|
||||
};
|
||||
bless $self,(ref($class) || $class);
|
||||
$self->{aliases} = $self->init_aliases();
|
||||
if ($self->{aliases} && $self->{aliases}->{attributes}
|
||||
&& !$self->{aliases}->{attributes}->{SERVER_VERSION}) {
|
||||
$self->{aliases}->{attributes}->{SERVER_VERSION} = sub {
|
||||
# A little bit nasty, I know, but we have to rebuild
|
||||
# the response since it is burried to deep into the
|
||||
# version fetching mechanism. Still thinking about
|
||||
# a cleaner solution .....
|
||||
return new JMX::Jmx4Perl::Response
|
||||
(
|
||||
value => shift->version(),
|
||||
status => 200,
|
||||
timestamp => time
|
||||
)
|
||||
};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $id = $handler->id()
|
||||
|
||||
Return the id of this handler, which must be unique among all handlers. This
|
||||
method is abstract and must be overwritten by a subclass
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
croak "Must be overwritten to return a name";
|
||||
}
|
||||
|
||||
=item $id = $handler->name()
|
||||
|
||||
Return this handler's name. This method returns by default the id, but can
|
||||
be overwritten by a subclass to provide something more descriptive.
|
||||
|
||||
=cut
|
||||
|
||||
sub name {
|
||||
return shift->id;
|
||||
}
|
||||
|
||||
=item $vendor = $handler->vendor()
|
||||
|
||||
Get the vendor for this product. If the handler support JSR 77 this is
|
||||
extracted directly from the JSR 77 information. Otherwise, as handler is
|
||||
recommended to detect the vendor on its own with a method C<_try_vendor>. Note, that he
|
||||
shoudl query the server for this information and return C<undef> if it could
|
||||
not be extracted from there. The default implementation of L</"autodetect">
|
||||
relies on the information fetched here.
|
||||
|
||||
=cut
|
||||
|
||||
sub vendor {
|
||||
return shift->_version_or_vendor("vendor");
|
||||
}
|
||||
|
||||
=item $version = $handler->version()
|
||||
|
||||
Get the version of the underlying application server or return C<undef> if the
|
||||
version can not be determined. Please note, that this method can be only called
|
||||
after autodetect() has been called since this call is normally used to fill in
|
||||
that version number.
|
||||
|
||||
=cut
|
||||
|
||||
sub version {
|
||||
return shift->_version_or_vendor("version");
|
||||
}
|
||||
|
||||
sub _version_or_vendor {
|
||||
my $self = shift;
|
||||
my $what = shift;
|
||||
my $transform = shift;
|
||||
die "Internal Error: '$what' must be either 'version' or 'vendor'"
|
||||
if $what ne "version" && $what ne "vendor";
|
||||
|
||||
if (!defined $self->{$what}) {
|
||||
if ($self->can("_try_$what")) {
|
||||
my $val;
|
||||
eval "\$self->_try_$what";
|
||||
die $@ if $@;
|
||||
} elsif ($self->jsr77) {
|
||||
$self->{$what} = $self->_server_info_from_jsr77("server" . (uc substr($what,0,1)) . substr($what,1));
|
||||
$self->{"original_" . $what} = $self->{$what};
|
||||
if ($transform && $self->{$what}) {
|
||||
if (ref($transform) eq "CODE") {
|
||||
$self->{$what} = &{$transform}($self->{$what});
|
||||
} elsif (ref($transform) eq "Regexp") {
|
||||
$self->{$what} = $1 if $self->{$what} =~ $transform;
|
||||
}
|
||||
}
|
||||
$self->{$what} ||= "" # Set to empty string if not found
|
||||
} else {
|
||||
die "Internal error: Not a JSR77 Handler and no _try_$what method";
|
||||
}
|
||||
}
|
||||
return $self->{$what};
|
||||
}
|
||||
|
||||
# Return the original version, which is not transformed. This contains
|
||||
# often the application info as well. This returns a subroutine, suitable
|
||||
# for usie in autodetect_pattern
|
||||
sub original_version_sub {
|
||||
return sub {
|
||||
my $self = shift;
|
||||
$self->version();
|
||||
return $self->{"original_version"};
|
||||
}
|
||||
}
|
||||
|
||||
=item $is_product = $handler->autodetect()
|
||||
|
||||
Return true, if the appserver to which the given L<JMX::Jmx4Perl> (at
|
||||
construction time) object is connected can be handled by this product
|
||||
handler. If this module detects that it definitely can not handle this
|
||||
application server, it returnd false. If an error occurs during autodectection,
|
||||
this method should return C<undef>.
|
||||
|
||||
=cut
|
||||
|
||||
sub autodetect {
|
||||
my $self = shift;
|
||||
my ($what,$pattern) = $self->autodetect_pattern;
|
||||
if ($what) {
|
||||
#print "W: $what P: $pattern\n";
|
||||
my $val;
|
||||
if (ref($what) eq "CODE") {
|
||||
$val = &{$what}($self);
|
||||
} else {
|
||||
eval "\$val = \$self->$what";
|
||||
die $@ if $@;
|
||||
}
|
||||
return 1 if ($val && (!$pattern || ref($pattern) ne "Regexp"));
|
||||
return $val =~ $pattern if ($val && $pattern);
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item ($what,$pattern) = $handler->autodetect_pattern()
|
||||
|
||||
Method returning a pattern which is applied to the vendor or version
|
||||
information provided by the L</"version"> or L</"vendor"> in order to detect,
|
||||
whether this handler matches the server queried. This pattern is used in the
|
||||
default implementation of C<autodetect> to check for a specific product. By
|
||||
default, this method returns (C<undef>,C<undef>) which implies, that autodetect
|
||||
for this handler returns false. Override this with the pattern matching the
|
||||
specific product to detect.
|
||||
|
||||
=cut
|
||||
|
||||
sub autodetect_pattern {
|
||||
return (undef,undef);
|
||||
}
|
||||
|
||||
=item $order = $handler->order()
|
||||
|
||||
Return some hint for the ordering of product handlers in the autodetection
|
||||
chain. This default implementation returns C<undef>, which implies no specific
|
||||
ordering. If a subclass returns an negative integer it will be put in front of
|
||||
the chain, if it returns a positive integer it will be put at the end of the
|
||||
chain, in ascending order, respectively. E.g for the autodetection chain, the
|
||||
ordering index of the included handlers looks like
|
||||
|
||||
-10,-5,-3,-1,undef,undef,undef,undef,undef,2,3,10000
|
||||
|
||||
The ordering index of the fallback handler (which always fire) is 1000, so it
|
||||
doesn't make sense to return a higher index for a custom producthandler.
|
||||
|
||||
=cut
|
||||
|
||||
sub order {
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item $can_jsr77 = $handler->jsr77()
|
||||
|
||||
Return true if the app server represented by this handler is an implementation
|
||||
of JSR77, which provides a well defined way how to access deployed applications
|
||||
and other stuff on a JEE Server. I.e. it defines how MBean representing this
|
||||
information has to be named. This base class returns false, but this method can
|
||||
be overwritten by a subclass.
|
||||
|
||||
=cut
|
||||
|
||||
sub jsr77 {
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item ($mbean,$attribute,$path) = $self->alias($alias)
|
||||
|
||||
=item ($mbean,$operation) = $self->alias($alias)
|
||||
|
||||
Return the mbean and attribute name for an registered attribute alias, for an
|
||||
operation alias, this method returns the mbean and the operation name. A
|
||||
subclass should call this parent method if it doesn't know about a specific
|
||||
alias, since JVM MXBeans are aliased here.
|
||||
|
||||
Returns undef if this product handler doesn't know about the provided alias.
|
||||
|
||||
=cut
|
||||
|
||||
sub alias {
|
||||
my ($self,$alias_or_name) = @_;
|
||||
my $alias;
|
||||
if (UNIVERSAL::isa($alias_or_name,"JMX::Jmx4Perl::Alias::Object")) {
|
||||
$alias = $alias_or_name;
|
||||
} else {
|
||||
$alias = JMX::Jmx4Perl::Alias->by_name($alias_or_name)
|
||||
|| croak "No alias $alias_or_name known";
|
||||
}
|
||||
my $resolved_ref = $self->resolve_alias($alias);
|
||||
# It has been defined by the handler, but set to 0. So it doesn't
|
||||
# support this particular alias
|
||||
return undef if (defined($resolved_ref) && !$resolved_ref);
|
||||
# If the handler doesn't define the ref (so it's undef),
|
||||
# use the default
|
||||
my $aliasref = $resolved_ref || $alias->default();
|
||||
# If there is no default, then there is no support, too.
|
||||
return undef unless defined($aliasref);
|
||||
|
||||
return $aliasref if (ref($aliasref) eq "CODE"); # return coderefs directly
|
||||
croak "Internal: $self doesn't resolve $alias to an arrayref" if ref($aliasref) ne "ARRAY";
|
||||
if (ref($aliasref->[0]) eq "CODE") {
|
||||
# Resolve dynamically if required
|
||||
$aliasref = &{$aliasref->[0]}($self);
|
||||
croak "Internal: $self doesn't resolve $alias to an arrayref" if ref($aliasref) ne "ARRAY";
|
||||
}
|
||||
return $aliasref ? @$aliasref : undef;
|
||||
}
|
||||
|
||||
=item $description = $self->info()
|
||||
|
||||
Get a textual description of the product handler. By default, it prints
|
||||
out the id, the version and well known properties known by the Java VM
|
||||
|
||||
=cut
|
||||
|
||||
sub info {
|
||||
my $self = shift;
|
||||
my $verbose = shift;
|
||||
|
||||
my $ret = "";
|
||||
$ret .= $self->server_info($verbose);
|
||||
$ret .= "-" x 80 . "\n";
|
||||
$ret .= $self->jvm_info($verbose);
|
||||
}
|
||||
|
||||
|
||||
# Examines internal alias hash in order to return handler specific aliases
|
||||
# Can be overwritten if something more esoteric is required
|
||||
sub resolve_alias {
|
||||
my $self = shift;
|
||||
my $alias = shift;
|
||||
croak "Not an alias object " unless (UNIVERSAL::isa($alias,"JMX::Jmx4Perl::Alias::Object"));
|
||||
my $aliases = $self->{aliases}->{$alias->{type} eq "attribute" ? "attributes" : "operations"};
|
||||
return $aliases && $aliases->{$alias->{alias}};
|
||||
}
|
||||
|
||||
|
||||
=item my $aliases = $self->init_aliases()
|
||||
|
||||
Method used during construction of a handler for obtaining a translation map of
|
||||
aliases to the real values. Each specific handler can overwrite this method to
|
||||
return is own resolving map. The returned map has two top level keys:
|
||||
C<attributes> and C<operations>. Below these keys are the maps for attribute
|
||||
and operation aliases, respectively. These two maps have alias names as keys
|
||||
(not the alias objects themselves) and a data structure for the getting to the
|
||||
aliased values. This data structure can be written in three variants:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
A arrayref having two or three string values for attributes describing the real
|
||||
MBean's name, the attribute name and an optional path within the value. For
|
||||
operations, it's an arrayref to an array with two elements: The MBean name and
|
||||
the operation name.
|
||||
|
||||
=item *
|
||||
|
||||
A arrayref to an array with a I<single> value which must be a coderef. This
|
||||
subroutine is called with the handler as single argument and is expected to
|
||||
return an arrayref in the form described above.
|
||||
|
||||
=item *
|
||||
|
||||
A coderef, which is executed when C<JMX::Jmx4Perl-E<gt>get_attribute()> or
|
||||
C<JMX::Jmx4Perl-E<gt>execute()> is called and which is supossed to do the complete
|
||||
lookup. The first argument to the subroutine is the handler which can be used
|
||||
to access the L<JMX::Jmx4Perl> object. The additional argument are either the
|
||||
value to set (for C<JMX::Jmx4Perl-E<gt>set_attribute()> or the operation's
|
||||
arguments for C<JMX::Jmx4Perl-E<gt>execute()>. This is the most flexible way for a
|
||||
handler to do anything it likes to do when an attribute value is requested or
|
||||
an operation is about to be executed. You have to return a
|
||||
L<JMX::Jmx4Perl::Response> object.
|
||||
|
||||
=back
|
||||
|
||||
Example :
|
||||
|
||||
sub init_aliases {
|
||||
my $self = shift;
|
||||
return {
|
||||
attributes => {
|
||||
SERVER_ADDRESS => [ "jboss.system:type=ServerInfo", "HostAddress"],
|
||||
SERVER_VERSION => sub {
|
||||
return shift->version();
|
||||
},
|
||||
SERVER_HOSTNAME => [ sub { return [ "jboss.system:type=ServerInfo", "HostName" ] } ]
|
||||
},
|
||||
operations => {
|
||||
THREAD_DUMP => [ "jboss.system:type=ServerInfo", "listThreadDump"]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
Of course, you are free to overwrite C<alias> or
|
||||
C<resolve_alias> on your own in order to do want you want it to do.
|
||||
|
||||
This default implementation returns an empty hashref.
|
||||
|
||||
=cut
|
||||
|
||||
sub init_aliases {
|
||||
my $self = shift;
|
||||
return {};
|
||||
}
|
||||
|
||||
|
||||
=item $has_attribute = $handler->try_attribute($jmx4perl,$property,$object,$attribute,$path)
|
||||
|
||||
Internal method which tries to request an attribute. If it could not be found,
|
||||
it returns false.
|
||||
|
||||
The first arguments C<$property> specifies an property of this object, which is
|
||||
set with the value of the found attribute or C<0> if this attribute does not
|
||||
exist.
|
||||
|
||||
The server call is cached internally by examing C<$property>. So, never change
|
||||
or set this property on this object manually.
|
||||
|
||||
=cut
|
||||
|
||||
sub try_attribute {
|
||||
my ($self,$property,$object,$attribute,$path) = @_;
|
||||
|
||||
my $jmx4perl = $self->{jmx4perl};
|
||||
|
||||
if (defined($self->{$property})) {
|
||||
return length($self->{$property});
|
||||
}
|
||||
my $request = JMX::Jmx4Perl::Request->new(READ,$object,$attribute,$path);
|
||||
my $response = $jmx4perl->request($request);
|
||||
if ($response->status == 404 || $response->status == 400) {
|
||||
$self->{$property} = "";
|
||||
} elsif ($response->is_ok) {
|
||||
$self->{$property} = $response->value;
|
||||
} else {
|
||||
croak "Error : ",$response->error_text();
|
||||
}
|
||||
return length($self->{$property});
|
||||
}
|
||||
|
||||
=item $server_info = $handler->server_info()
|
||||
|
||||
Get's a textual description of the server. By default, this includes the id and
|
||||
the version, but can (and should) be overidden by a subclass to contain more
|
||||
specific information
|
||||
|
||||
=cut
|
||||
|
||||
sub server_info {
|
||||
my $self = shift;
|
||||
my $jmx4perl = $self->{jmx4perl};
|
||||
my $ret = "";
|
||||
$ret .= sprintf("%-10.10s %s\n","Name:",$self->name);
|
||||
$ret .= sprintf("%-10.10s %s\n","Vendor:",$self->vendor) if $self->vendor && $self->vendor ne $self->name;
|
||||
$ret .= sprintf("%-10.10s %s\n","Version:",$self->version) if $self->version;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=item $jvm_info = $handler->jvm_info()
|
||||
|
||||
Get information which is based on well known MBeans which are available for
|
||||
every Virtual machine. This is a textual representation of the information.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub jvm_info {
|
||||
my $self = shift;
|
||||
my $verbose = shift;
|
||||
my $jmx4perl = $self->{jmx4perl};
|
||||
|
||||
my @info = (
|
||||
"Memory" => [
|
||||
"mem" => [ "Heap-Memory used", MEMORY_HEAP_USED ],
|
||||
"mem" => [ "Heap-Memory alloc", MEMORY_HEAP_COMITTED ],
|
||||
"mem" => [ "Heap-Memory max", MEMORY_HEAP_MAX ],
|
||||
"mem" => [ "NonHeap-Memory max", MEMORY_NONHEAP_MAX ],
|
||||
],
|
||||
"Classes" => [
|
||||
"nr" => [ "Classes loaded", CL_LOADED ],
|
||||
"nr" => [ "Classes total", CL_TOTAL ]
|
||||
],
|
||||
"Threads" => [
|
||||
"nr" => [ "Threads current", THREAD_COUNT ],
|
||||
"nr" => [ "Threads peak", THREAD_COUNT_PEAK ]
|
||||
],
|
||||
"OS" => [
|
||||
"str" => [ "CPU Arch", OS_INFO_ARCH ],
|
||||
"str" => [ "CPU OS",OS_INFO_NAME,OS_INFO_VERSION],
|
||||
"mem" => [ "Memory total",OS_MEMORY_PHYSICAL_FREE],
|
||||
"mem" => [ "Memory free",OS_MEMORY_PHYSICAL_FREE],
|
||||
"mem" => [ "Swap total",OS_MEMORY_SWAP_TOTAL],
|
||||
"mem" => [ "Swap free",OS_MEMORY_SWAP_FREE],
|
||||
"nr" => [ "FileDesc Open", OS_FILE_DESC_OPEN ],
|
||||
"nr" => [ "FileDesc Max", OS_FILE_DESC_MAX ]
|
||||
],
|
||||
"Runtime" => [
|
||||
"str" => [ "Name", RUNTIME_NAME ],
|
||||
"str" => [ "JVM", RUNTIME_VM_VERSION,RUNTIME_VM_NAME,RUNTIME_VM_VENDOR ],
|
||||
"duration" => [ "Uptime", RUNTIME_UPTIME ],
|
||||
"time" => [ "Starttime", RUNTIME_STARTTIME ]
|
||||
]
|
||||
);
|
||||
my $ret = "";
|
||||
|
||||
# Collect all alias and create a map with values
|
||||
my $info_map = $self->_fetch_info(\@info);
|
||||
# Prepare output
|
||||
while (@info) {
|
||||
my $titel = shift @info;
|
||||
my $e = shift @info;
|
||||
my $val = "";
|
||||
while (@$e) {
|
||||
$self->_append_info($info_map,\$val,shift @$e,shift @$e);
|
||||
}
|
||||
if (length $val) {
|
||||
$ret .= $titel . ":\n";
|
||||
$ret .= $val;
|
||||
}
|
||||
}
|
||||
|
||||
if ($verbose) {
|
||||
my $args = "";
|
||||
my $rt_args = $self->_get_attribute(RUNTIME_ARGUMENTS);
|
||||
if ($rt_args) {
|
||||
for my $arg (@{$rt_args}) {
|
||||
$args .= $arg . " ";
|
||||
my $i = 1;
|
||||
if (length($args) > $i * 60) {
|
||||
$args .= "\n" . (" " x 24);
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
$ret .= sprintf(" %-20.20s %s\n","Arguments:",$args);
|
||||
}
|
||||
my $sys_props = $self->_get_attribute(RUNTIME_SYSTEM_PROPERTIES);
|
||||
if ($sys_props) {
|
||||
$ret .= "System Properties:\n";
|
||||
if (ref($sys_props) eq "HASH") {
|
||||
$sys_props = [ values %$sys_props ];
|
||||
}
|
||||
for my $prop (@{$sys_props}) {
|
||||
$ret .= sprintf(" %-40.40s = %s\n",$prop->{key},$prop->{value});
|
||||
}
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# Bulk fetch of alias information
|
||||
# Return: Map with aliases as keys and response values as values
|
||||
sub _fetch_info {
|
||||
my $self = shift;
|
||||
my $info = shift;
|
||||
my $jmx4perl = $self->{jmx4perl};
|
||||
my @reqs = ();
|
||||
my @aliases = ();
|
||||
my $info_map = {};
|
||||
for (my $i=1; $i < @$info; $i += 2) {
|
||||
my $attr_list = $info->[$i];
|
||||
for (my $j=1;$j < @$attr_list;$j += 2) {
|
||||
my $alias_list = $attr_list->[$j];
|
||||
for (my $k=1;$k < @$alias_list;$k++) {
|
||||
my $alias = $alias_list->[$k];
|
||||
my @args = $jmx4perl->resolve_alias($alias);
|
||||
next unless $args[0];
|
||||
push @reqs,new JMX::Jmx4Perl::Request(READ,@args);
|
||||
push @aliases,$alias;
|
||||
}
|
||||
}
|
||||
}
|
||||
my @resps = $jmx4perl->request(@reqs);
|
||||
#print Dumper(\@resps);
|
||||
foreach my $resp (@resps) {
|
||||
my $alias = shift @aliases;
|
||||
if ($resp->{status} == 200) {
|
||||
$info_map->{$alias} = $resp->{value};
|
||||
}
|
||||
}
|
||||
return $info_map;
|
||||
}
|
||||
|
||||
# Fetch version and vendor from jrs77
|
||||
sub _server_info_from_jsr77 {
|
||||
my $self = shift;
|
||||
my $info = shift;
|
||||
my $jmx = $self->{jmx4perl};
|
||||
|
||||
my $servers = $jmx->search("*:j2eeType=J2EEServer,*");
|
||||
return "" if (!$servers || !@$servers);
|
||||
|
||||
# Take first server and lookup its version
|
||||
return $jmx->get_attribute($servers->[0],$info);
|
||||
}
|
||||
|
||||
|
||||
sub _append_info {
|
||||
my $self = shift;
|
||||
my $info_map = shift;
|
||||
my $r = shift;
|
||||
my $type = shift;
|
||||
my $content = shift;
|
||||
my $label = shift @$content;
|
||||
my $value = $info_map->{shift @$content};
|
||||
return unless defined($value);
|
||||
if ($type eq "mem") {
|
||||
$value = int($value/(1024*1024)) . " MB";
|
||||
} elsif ($type eq "str" && @$content) {
|
||||
while (@$content) {
|
||||
$value .= " " . $info_map->{shift @$content};
|
||||
}
|
||||
} elsif ($type eq "duration") {
|
||||
$value = &_format_duration($value);
|
||||
} elsif ($type eq "time") {
|
||||
$value = scalar(localtime($value/1000));
|
||||
}
|
||||
$$r .= sprintf(" %-20.20s: %s\n",$label,$value);
|
||||
}
|
||||
|
||||
sub _get_attribute {
|
||||
my $self = shift;
|
||||
|
||||
my $jmx4perl = $self->{jmx4perl};
|
||||
my @args = $jmx4perl->resolve_alias(shift);
|
||||
return undef unless $args[0];
|
||||
my $request = new JMX::Jmx4Perl::Request(READ,@args);
|
||||
my $response = $jmx4perl->request($request);
|
||||
return undef if $response->status == 404; # Ignore attributes not found
|
||||
return $response->value if $response->is_ok;
|
||||
die "Error fetching attribute ","@_",": ",$response->error_text;
|
||||
}
|
||||
|
||||
sub _format_duration {
|
||||
my $millis = shift;
|
||||
my $total = int($millis/1000);
|
||||
my $days = int($total/(60*60*24));
|
||||
$total -= $days * 60 * 60 * 24;
|
||||
my $hours = int($total/(60*60));
|
||||
$total -= $hours * 60 * 60;
|
||||
my $minutes = int($total/60);
|
||||
$total -= $minutes * 60;
|
||||
my $seconds = $total;
|
||||
my $ret = "";
|
||||
$ret .= "$days d, " if $days;
|
||||
$ret .= "$hours h, " if $hours;
|
||||
$ret .= "$minutes m, " if $minutes;
|
||||
$ret .= "$seconds s" if $seconds;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
90
lib/JMX/Jmx4Perl/Product/Geronimo.pm
Normal file
90
lib/JMX/Jmx4Perl/Product/Geronimo.pm
Normal file
@@ -0,0 +1,90 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Geronimo;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Geronimo - Handler for Geronimo
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler supporting Geronimo 2 (L<http://geronimo.apache.org/>)
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "geronimo";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Apache Geronimo";
|
||||
}
|
||||
|
||||
# Not that popular
|
||||
sub order {
|
||||
return 10;
|
||||
}
|
||||
|
||||
sub autodetect {
|
||||
my $self = shift;
|
||||
my $info = shift;
|
||||
my $jmx = $self->{jmx4perl};
|
||||
|
||||
my $servers = $jmx->search("geronimo:j2eeType=J2EEServer,*");
|
||||
return $servers && @$servers;
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
return
|
||||
{
|
||||
attributes =>
|
||||
{
|
||||
#SERVER_ADDRESS => [ "jboss.system:type=ServerInfo", "HostAddress"],
|
||||
#SERVER_HOSTNAME => [ "Catalina:type=Engine", "defaultHost"],
|
||||
},
|
||||
operations =>
|
||||
{
|
||||
#THREAD_DUMP => [ "jboss.system:type=ServerInfo", "listThreadDump"]
|
||||
}
|
||||
# Alias => [ "mbean", "attribute", "path" ]
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
99
lib/JMX/Jmx4Perl/Product/Glassfish.pm
Normal file
99
lib/JMX/Jmx4Perl/Product/Glassfish.pm
Normal file
@@ -0,0 +1,99 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Glassfish;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Glassfish - Handler for Glassfish
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This handler supports glassfish up to version 3.1
|
||||
(L<https://glassfish.dev.java.net/>)
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "glassfish";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Glassfish";
|
||||
}
|
||||
|
||||
sub version {
|
||||
my $self = shift;
|
||||
my $version = $self->_version_or_vendor("version",qr/([\d\.]+)/m);
|
||||
return $version if $version;
|
||||
|
||||
# Try for Glassfish V3
|
||||
my $jmx = $self->{jmx4perl};
|
||||
|
||||
my $servers = $jmx->search("com.sun.appserv:type=Host,*");
|
||||
if ($servers) {
|
||||
$self->{"original_version"} = "GlassFish V3";
|
||||
$self->{"version"} = "3";
|
||||
return "3";
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub vendor {
|
||||
return "Oracle";
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return (shift->original_version_sub,qr/GlassFish/i);
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
return
|
||||
{
|
||||
attributes =>
|
||||
{
|
||||
},
|
||||
operations =>
|
||||
{
|
||||
THREAD_DUMP => [ "com.sun.appserv:category=monitor,server=server,type=JVMInformation", "getThreadDump"]
|
||||
}
|
||||
# Alias => [ "mbean", "attribute", "path" ]
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
78
lib/JMX/Jmx4Perl/Product/Hadoop.pm
Normal file
78
lib/JMX/Jmx4Perl/Product/Hadoop.pm
Normal file
@@ -0,0 +1,78 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Hadoop;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
use Data::Dumper;
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Hadoop - Handler for Hadoop
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support Hadoop (L<http://hadoop.apache.org/>)
|
||||
which works with the JVM Agent provided for Sun JDK 6 based applications.
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "hadoop";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Hadoop";
|
||||
}
|
||||
|
||||
sub vendor {
|
||||
return "Apache";
|
||||
}
|
||||
|
||||
sub version {
|
||||
# No way to detect version until yet.
|
||||
return "";
|
||||
}
|
||||
sub order {
|
||||
return 220;
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return sub {
|
||||
my $self = shift;
|
||||
my $j4p = $self->{jmx4perl};
|
||||
my $ret = $j4p->search("hadoop:*");
|
||||
#print Dumper($ret);
|
||||
return $ret;
|
||||
};
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
87
lib/JMX/Jmx4Perl/Product/JBoss.pm
Normal file
87
lib/JMX/Jmx4Perl/Product/JBoss.pm
Normal file
@@ -0,0 +1,87 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::JBoss;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::JBoss - Handler for JBoss
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support JBoss 4.x and JBoss 5.x (L<http://www.jboss.org/jbossas/>)
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "jboss";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "JBoss AS";
|
||||
}
|
||||
|
||||
sub order {
|
||||
return -2;
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub version {
|
||||
return shift->_version_or_vendor("version",qr/^(.*?)\s+/);
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return ("vendor",qr/JBoss/i);
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
return
|
||||
{
|
||||
attributes =>
|
||||
{
|
||||
SERVER_ADDRESS => [ "jboss.system:type=ServerInfo", "HostAddress"],
|
||||
SERVER_HOSTNAME => [ "jboss.system:type=ServerInfo", "HostName"],
|
||||
},
|
||||
operations =>
|
||||
{
|
||||
THREAD_DUMP => [ "jboss.system:type=ServerInfo", "listThreadDump"]
|
||||
}
|
||||
# Alias => [ "mbean", "attribute", "path" ]
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
106
lib/JMX/Jmx4Perl/Product/Jetty.pm
Normal file
106
lib/JMX/Jmx4Perl/Product/Jetty.pm
Normal file
@@ -0,0 +1,106 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Jetty;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Jetty - Handler for Jetty
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support Jetty. It supports Jetty version 5, 6 and 7.
|
||||
(L<http://www.mortbay.org/jetty/>)
|
||||
|
||||
Please note, that you must have JMX support enabled in Jetty for autodetection
|
||||
and aliasing to work. See the Jetty documentation for details.
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "jetty";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Jetty";
|
||||
}
|
||||
|
||||
sub _try_version {
|
||||
my $self = shift;
|
||||
my $jmx = $self->{jmx4perl};
|
||||
|
||||
# Jetty V6 & 7
|
||||
my $servers = $jmx->search("*:id=0,type=server,*");
|
||||
my $ret;
|
||||
if ($servers) {
|
||||
$ret = $self->try_attribute("version",$servers->[0],"version");
|
||||
}
|
||||
|
||||
# Jetty V5
|
||||
if (!length($self->{version})) {
|
||||
delete $self->{version};
|
||||
$ret = $self->try_attribute("version","org.mortbay:jetty=default","version");
|
||||
}
|
||||
|
||||
$self->{version} =~ s/Jetty\/([^\s]+).*/$1/;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return "version";
|
||||
}
|
||||
|
||||
sub vendor {
|
||||
return "Mortbay";
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
return
|
||||
{
|
||||
attributes =>
|
||||
{
|
||||
},
|
||||
operations =>
|
||||
{
|
||||
THREAD_DUMP => [ "jboss.system:type=ServerInfo", "listThreadDump"]
|
||||
}
|
||||
# Alias => [ "mbean", "attribute", "path" ]
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
89
lib/JMX/Jmx4Perl/Product/Jonas.pm
Normal file
89
lib/JMX/Jmx4Perl/Product/Jonas.pm
Normal file
@@ -0,0 +1,89 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Jonas;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Jonas - Handler for Jonas
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support Jonas 4 and 5 (L<http://jonas.ow2.org/>)
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "jonas";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Jonas";
|
||||
}
|
||||
|
||||
sub order {
|
||||
return 10;
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return ("vendor",qr/OW2/i);
|
||||
}
|
||||
|
||||
sub server_info {
|
||||
my $self = shift;
|
||||
my $ret = $self->SUPER::server_info();
|
||||
$ret .= sprintf("%-10.10s %s\n","Web:",$self->{jmx4perl}->get_attribute("jonas:name=webContainers,type=service","ServerName"));
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
return
|
||||
{
|
||||
attributes =>
|
||||
{
|
||||
#SERVER_ADDRESS => [ "jboss.system:type=ServerInfo", "HostAddress"],
|
||||
#SERVER_HOSTNAME => [ "jonas:name=jonas,type=ServerProxy", "HostName"],
|
||||
},
|
||||
operations =>
|
||||
{
|
||||
#THREAD_DUMP => [ "jboss.system:type=ServerInfo", "listThreadDump"]
|
||||
}
|
||||
# Alias => [ "mbean", "attribute", "path" ]
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
92
lib/JMX/Jmx4Perl/Product/Resin.pm
Normal file
92
lib/JMX/Jmx4Perl/Product/Resin.pm
Normal file
@@ -0,0 +1,92 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Resin;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Resin - Handler for Resin
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support Resind 3 and 4 (L<http://www.caucho.com/>)
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "resin";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Resin";
|
||||
}
|
||||
|
||||
sub order {
|
||||
return 110;
|
||||
}
|
||||
|
||||
sub _try_version {
|
||||
my $self = shift;
|
||||
my $ret = $self->try_attribute("version","resin:type=Resin","Version");
|
||||
if ($ret) {
|
||||
$self->{version} =~ s|^.*?([\d.]+).*$|$1|;
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return ("version");
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
return
|
||||
{
|
||||
attributes =>
|
||||
{
|
||||
#SERVER_ADDRESS => [ "jboss.system:type=ServerInfo", "HostAddress"],
|
||||
#SERVER_HOSTNAME => [ "jonas:name=jonas,type=ServerProxy", "HostName"],
|
||||
},
|
||||
operations =>
|
||||
{
|
||||
#THREAD_DUMP => [ "jboss.system:type=ServerInfo", "listThreadDump"]
|
||||
}
|
||||
# Alias => [ "mbean", "attribute", "path" ]
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
87
lib/JMX/Jmx4Perl/Product/SpringDM.pm
Normal file
87
lib/JMX/Jmx4Perl/Product/SpringDM.pm
Normal file
@@ -0,0 +1,87 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::SpringDM;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
use Data::Dumper;
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::SpringDM - Handler for Spring dm-Server.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support for Spring dm Server
|
||||
(L<http://www.springsource.com/products/dmserver>).
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "springdm";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Spring dm-Server";
|
||||
}
|
||||
|
||||
sub vendor {
|
||||
return "SpringSource";
|
||||
}
|
||||
|
||||
sub order {
|
||||
return 300;
|
||||
}
|
||||
|
||||
sub version {
|
||||
return shift->{version};
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return sub {
|
||||
my $self = shift;
|
||||
my $j4p = $self->{jmx4perl};
|
||||
my $ret = $j4p->search("com.springsource.kernel:name=com.springsource.kernel.agent.dm,*");
|
||||
#print Dumper($ret);
|
||||
if ($ret) {
|
||||
for my $n (@$ret) {
|
||||
my ($domain,$attrs) = $j4p->parse_name($n);
|
||||
if ($attrs->{version}) {
|
||||
$self->{version} = $attrs->{version};
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
};
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
83
lib/JMX/Jmx4Perl/Product/Terracotta.pm
Normal file
83
lib/JMX/Jmx4Perl/Product/Terracotta.pm
Normal file
@@ -0,0 +1,83 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Terracotta;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
use Data::Dumper;
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Terracotta - Handler for Terracotta server
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support Terracotta (L<http://www.terracotta.org/>)
|
||||
which works with the JVM Agent provided for Sun JDK 6 based applications.
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "terracotta";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Terracotta";
|
||||
}
|
||||
|
||||
|
||||
sub order {
|
||||
return 210;
|
||||
}
|
||||
|
||||
sub vendor {
|
||||
return "Terracotta";
|
||||
}
|
||||
|
||||
sub version {
|
||||
return shift->{version};
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return sub {
|
||||
my $self = shift;
|
||||
my $j4p = $self->{jmx4perl};
|
||||
my $found = $self->try_attribute("version","org.terracotta.internal:name=Terracotta Server,type=Terracotta Server","Version");
|
||||
if ($found) {
|
||||
$self->{version} =~ s/.*?([\d\.]+).*/$1/;
|
||||
return 1;
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
96
lib/JMX/Jmx4Perl/Product/Tomcat.pm
Normal file
96
lib/JMX/Jmx4Perl/Product/Tomcat.pm
Normal file
@@ -0,0 +1,96 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Tomcat;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Tomcat - Handler for Apache Tomcat
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler supporting Tomcat, Version 4, 5 and 6. (http://tomcat.apache.org/)
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "tomcat";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Apache Tomcat";
|
||||
}
|
||||
|
||||
# Pure Tomcat must be *after* all App-Servers using tomcat as web container
|
||||
sub order {
|
||||
return 20;
|
||||
}
|
||||
|
||||
sub _try_version {
|
||||
my $self = shift;
|
||||
my $ret = $self->try_attribute("version","Catalina:type=Server","serverInfo");
|
||||
if ($ret) {
|
||||
$self->{version} =~ s/^.*?\/?(\d.+)$/$1/;
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return "version";
|
||||
}
|
||||
|
||||
sub vendor {
|
||||
return "Apache";
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
return
|
||||
{
|
||||
attributes =>
|
||||
{
|
||||
#SERVER_ADDRESS => [ "jboss.system:type=ServerInfo", "HostAddress"],
|
||||
SERVER_HOSTNAME => [ "Catalina:type=Engine", "defaultHost"],
|
||||
},
|
||||
operations =>
|
||||
{
|
||||
#THREAD_DUMP => [ "jboss.system:type=ServerInfo", "listThreadDump"]
|
||||
}
|
||||
# Alias => [ "mbean", "attribute", "path" ]
|
||||
};
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
89
lib/JMX/Jmx4Perl/Product/Unknown.pm
Normal file
89
lib/JMX/Jmx4Perl/Product/Unknown.pm
Normal file
@@ -0,0 +1,89 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Unknown;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use JMX::Jmx4Perl;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Unknown - Fallback handler
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This fallback handler runs always as I<last> in the autodetection chain and
|
||||
provides at least informations about the platform MXMBeans which are available
|
||||
on any Java 5 platform.
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "unknown";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "unknown";
|
||||
}
|
||||
|
||||
# Highest ordering number
|
||||
sub order {
|
||||
return 1000;
|
||||
}
|
||||
|
||||
sub info {
|
||||
my $self = shift;
|
||||
my $verbose = shift;
|
||||
|
||||
my $ret = $self->jvm_info($verbose);
|
||||
$ret .= "-" x 80 . "\n";
|
||||
$ret .= "The application server's brand could not be auto-detected.\n";
|
||||
$ret .= "Known brands are: " . (join ", ",grep { $_ ne "unknown"} @JMX::Jmx4Perl::PRODUCT_HANDLER_ORDERING) . "\n\n";
|
||||
$ret .=
|
||||
"Please submit the output of 'jmx4perl list' and 'jmx4perl attributes' to\n" .
|
||||
"roland\@cpan.de in order to provide a new product handler in the next release\n";
|
||||
}
|
||||
|
||||
sub autodetect {
|
||||
# Since we are the last one in the chain, we will be the one 'found'
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub version {
|
||||
return "";
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
131
lib/JMX/Jmx4Perl/Product/Weblogic.pm
Normal file
131
lib/JMX/Jmx4Perl/Product/Weblogic.pm
Normal file
@@ -0,0 +1,131 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Weblogic;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use JMX::Jmx4Perl::Request;
|
||||
use Data::Dumper;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Weblogic - Handler for Oracle WebLogic
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support for Oracle Weblogic Server 9 and 10
|
||||
(L<http://www.oracle.com/appserver/>)
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "weblogic";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "Oracle WebLogic Server";
|
||||
}
|
||||
|
||||
sub order {
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _try_version {
|
||||
my $self = shift;
|
||||
my $is_weblogic = $self->_try_server_domain;
|
||||
return undef unless $is_weblogic;
|
||||
return $self->try_attribute("version",$self->{server_domain},"ConfigurationVersion");
|
||||
}
|
||||
|
||||
sub vendor {
|
||||
return "Oracle";
|
||||
}
|
||||
|
||||
sub server_info {
|
||||
my $self = shift;
|
||||
my $ret = $self->SUPER::server_info();
|
||||
$ret .= sprintf("%-10.10s %s\n","IP:",$self->{jmx4perl}->get_attribute("SERVER_ADDRESS"));
|
||||
}
|
||||
|
||||
sub _try_server_domain {
|
||||
my $self = shift;
|
||||
return $self->try_attribute
|
||||
("server_domain",
|
||||
"com.bea:Name=RuntimeService,Type=weblogic.management.mbeanservers.runtime.RuntimeServiceMBean",
|
||||
"DomainConfiguration",
|
||||
"objectName");
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return ("version",1);
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
return
|
||||
{
|
||||
attributes => {
|
||||
SERVER_ADDRESS => [ sub {
|
||||
my $self = shift;
|
||||
$self->_try_server_domain;
|
||||
$self->try_attribute("admin_server",
|
||||
$self->{server_domain},
|
||||
"AdminServerName");
|
||||
return [ "com.bea:Name=" . $self->{admin_server} . ",Type=ServerRuntime",
|
||||
"AdminServerHost" ];
|
||||
}],
|
||||
},
|
||||
operations => {
|
||||
# Needs to be done in a more complex. Depends on admin server name *and*
|
||||
# JVM used
|
||||
THREAD_DUMP => \&exec_thread_dump
|
||||
}
|
||||
# Alias => [ "mbean", "attribute", "path" ]
|
||||
};
|
||||
}
|
||||
|
||||
sub exec_thread_dump {
|
||||
my $self = shift;
|
||||
my $jmx = $self->{jmx4perl};
|
||||
|
||||
my $beans = $jmx->search("com.bea:Type=JRockitRuntime,*");
|
||||
if ($beans && @{$beans}) {
|
||||
my $bean = $beans->[0];
|
||||
my $request = new JMX::Jmx4Perl::Request(READ,$bean,"ThreadStackDump");
|
||||
return $jmx->request($request);
|
||||
}
|
||||
die $self->name,": Cannot execute THREAD_DUMP because I can't find a suitable JRockitRuntime";
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
88
lib/JMX/Jmx4Perl/Product/Websphere.pm
Normal file
88
lib/JMX/Jmx4Perl/Product/Websphere.pm
Normal file
@@ -0,0 +1,88 @@
|
||||
#!/usr/bin/perl
|
||||
package JMX::Jmx4Perl::Product::Websphere;
|
||||
|
||||
use JMX::Jmx4Perl::Product::BaseHandler;
|
||||
use strict;
|
||||
use base "JMX::Jmx4Perl::Product::BaseHandler";
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Product::Websphere - Handler for IBM Websphere
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the product handler support for IBM Websphere Application Server 6 and
|
||||
7 (L<http://www.ibm.com/>)
|
||||
|
||||
=cut
|
||||
|
||||
sub id {
|
||||
return "websphere";
|
||||
}
|
||||
|
||||
sub name {
|
||||
return "IBM Websphere Application Server";
|
||||
}
|
||||
|
||||
|
||||
sub version {
|
||||
return shift->_version_or_vendor("version",qr/^Version\s+(\d.*)\s*$/m);
|
||||
}
|
||||
|
||||
sub autodetect_pattern {
|
||||
return (shift->original_version_sub,qr/IBM\s+WebSphere\s+Application\s+Server/i);
|
||||
}
|
||||
|
||||
sub order {
|
||||
return 100;
|
||||
}
|
||||
|
||||
sub jsr77 {
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub init_aliases {
|
||||
my $self = shift;
|
||||
return {
|
||||
attributes => {
|
||||
OS_CPU_TIME => 0, # Don't support these ones
|
||||
OS_FILE_DESC_MAX => 0,
|
||||
OS_FILE_DESC_OPEN => 0,
|
||||
OS_MEMORY_PHYSICAL_FREE => 0,
|
||||
OS_MEMORY_PHYSICAL_TOTAL => 0,
|
||||
OS_MEMORY_SWAP_FREE => 0,
|
||||
OS_MEMORY_SWAP_TOTAL => 0,
|
||||
OS_MEMORY_VIRTUAL => 0
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
426
lib/JMX/Jmx4Perl/Request.pm
Normal file
426
lib/JMX/Jmx4Perl/Request.pm
Normal file
@@ -0,0 +1,426 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Request - A jmx4perl request
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$req = JMX::Jmx4Perl::Request->new(READ,$mbean,$attribute);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A L<JMX::Jmx4Perl::Request> encapsulates a request for various operational
|
||||
types.
|
||||
|
||||
The following attributes are available:
|
||||
|
||||
=over
|
||||
|
||||
=item mbean
|
||||
|
||||
Name of the targetted mbean in its canonical format.
|
||||
|
||||
=item type
|
||||
|
||||
Type of request, which should be one of the constants
|
||||
|
||||
=over
|
||||
|
||||
=item READ
|
||||
|
||||
Get the value of a attribute
|
||||
|
||||
=item WRITE
|
||||
|
||||
Write an attribute
|
||||
|
||||
=item EXEC
|
||||
|
||||
Execute an JMX operation
|
||||
|
||||
=item LIST
|
||||
|
||||
List all MBeans available
|
||||
|
||||
=item SEARCH
|
||||
|
||||
Search for MBeans
|
||||
|
||||
=item AGENT_VERSION
|
||||
|
||||
Get the agent's version and extra runtime information of the serverside.
|
||||
|
||||
=item REGISTER_NOTIFICATION
|
||||
|
||||
Register for a JMX notification (not supported yet)
|
||||
|
||||
=item REMOVE_NOTIFICATION
|
||||
|
||||
Remove a JMX notification (not supported yet)
|
||||
|
||||
=back
|
||||
|
||||
=item attribute
|
||||
|
||||
If type is C<READ> or C<WRITE> this specifies the requested
|
||||
attribute
|
||||
|
||||
=item value
|
||||
|
||||
For C<WRITE> this specifies the value to set
|
||||
|
||||
=item arguments
|
||||
|
||||
List of arguments of C<EXEC> operations
|
||||
|
||||
=item path
|
||||
|
||||
This optional parameter can be used to specify a nested value in an complex
|
||||
mbean attribute or nested return value from a JMX operation. For example, the
|
||||
MBean C<java.lang:type=Memory>'s attribute C<HeapMemoryUsage> is a complex
|
||||
value, which looks in the JSON representation like
|
||||
|
||||
"value":{"init":0,"max":518979584,"committed":41381888,"used":33442568}
|
||||
|
||||
So, to fetch the C<"used"> value only, specify C<used> as path within the
|
||||
request. You can access deeper nested values by building up a path with "/" as
|
||||
separator. This looks a bit like a simplified form of XPath.
|
||||
|
||||
=item maxDepth, maxObjects, maxCollectionSize, ignoreErrors
|
||||
|
||||
With these number you can restrict the size of the JSON structure
|
||||
returned. C<maxDepth> gives the maximum nesting level of the JSON
|
||||
object,C<maxObjects> returns the maximum number of objects to be returned in
|
||||
total and C<maxCollectionSize> restrict the number of all arrays and
|
||||
collections (maps, lists) in the answer. Note, that you should use this
|
||||
restrictions if you are doing massive bulk operations. C<ignoreErrors> is
|
||||
useful for read requests with multiple attributes to skip errors while reading
|
||||
attribute values on the errors side (the error text will be set as value).
|
||||
|
||||
=item target
|
||||
|
||||
If given, the request is processed by the agent in proxy mode, i.e. it will
|
||||
proxy to another server exposing via a JSR-160 connector. C<target> is a hash
|
||||
which contains information how to reach the target service via the proxy. This
|
||||
hash knows the following keys:
|
||||
|
||||
=over
|
||||
|
||||
=item url
|
||||
|
||||
JMX service URL as specified in JSR-160 pointing to the target server.
|
||||
|
||||
=item env
|
||||
|
||||
Further context information which is another hash.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
package JMX::Jmx4Perl::Request;
|
||||
|
||||
use strict;
|
||||
use vars qw(@EXPORT);
|
||||
use Carp;
|
||||
use Data::Dumper;
|
||||
|
||||
use base qw(Exporter);
|
||||
@EXPORT = (
|
||||
"READ","WRITE","EXEC","LIST", "SEARCH",
|
||||
"REGNOTIF","REMNOTIF", "AGENT_VERSION"
|
||||
);
|
||||
|
||||
use constant READ => "read";
|
||||
use constant WRITE => "write";
|
||||
use constant EXEC => "exec";
|
||||
use constant LIST => "list";
|
||||
use constant SEARCH => "search";
|
||||
use constant REGNOTIF => "regnotif";
|
||||
use constant REMNOTIF => "remnotif";
|
||||
use constant AGENT_VERSION => "version";
|
||||
|
||||
my $TYPES =
|
||||
{ map { $_ => 1 } (READ, WRITE, EXEC, LIST, SEARCH,
|
||||
REGNOTIF, REMNOTIF, AGENT_VERSION) };
|
||||
|
||||
=item $req = new JMX::Jmx4Perl::Request(....);
|
||||
|
||||
$req = new JMX::Jmx4Perl::Request(READ,$mbean,$attribute,$path, { ... options ... } );
|
||||
$req = new JMX::Jmx4Perl::Request(READ,{ mbean => $mbean,... });
|
||||
$req = new JMX::Jmx4Perl::Request({type => READ, mbean => $mbean, ... });
|
||||
|
||||
The constructor can be used in various way. In the simplest form, you provide
|
||||
the type as first argument and depending on the type one or more additional
|
||||
attributes which specify the request. The second form uses the type as first
|
||||
parameter and a hashref containing named parameter for the request parameters
|
||||
(for the names, see above). Finally you can specify the arguments completely as
|
||||
a hashref, using 'type' for the entry specifying the request type.
|
||||
|
||||
For the options C<maxDepth>, C<maxObjects> and C<maxCollectionSize>, you can mix
|
||||
them in into the hashref if using the hashed argument format. For the first
|
||||
format, these options are given as a final hashref.
|
||||
|
||||
The option C<method> can be used to suggest a HTTP request method to use. By
|
||||
default, the agent decides automatically which HTTP method to use depending on
|
||||
the number of requests and whether an extended format should be used (which is
|
||||
only possible with an HTTP POST request). The value of this option can be
|
||||
either C<post> or C<get>, dependening on your preference.
|
||||
|
||||
If the request should be proxied through this request, a target configuration
|
||||
needs to be given as optional parameter. The target configuration consists of a
|
||||
JMX service C<url> and a optional environment, which is given as a key-value
|
||||
map. For example
|
||||
|
||||
$req = new JMX::Jmx4Perl::Request(..., {
|
||||
target => {
|
||||
url => "",
|
||||
env => { ..... }
|
||||
}
|
||||
} );
|
||||
|
||||
Note, depending on the type, some parameters are mandatory. The mandatory
|
||||
parameters and the order of the arguments for the constructor variant without
|
||||
named parameters are:
|
||||
|
||||
=over
|
||||
|
||||
=item C<READ>
|
||||
|
||||
Order : $mbean, $attribute, $path
|
||||
Mandatory: $mbean, $attribute
|
||||
|
||||
Note that C<$attribute> can be either a single name or a reference to a list
|
||||
of attribute names.
|
||||
|
||||
=item C<WRITE>
|
||||
|
||||
Order : $mbean, $attribute, $value, $path
|
||||
Mandatory: $mbean, $attribute, $value
|
||||
|
||||
=item C<EXEC>
|
||||
|
||||
Order : $mbean, $operation, $arg1, $arg2, ...
|
||||
Mandatory: $mbean, $operation
|
||||
|
||||
|
||||
=item C<LIST>
|
||||
|
||||
Order : $path
|
||||
|
||||
=item C<SEARCH>
|
||||
|
||||
Order : $pattern
|
||||
Mandatory: $pattern
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $type = shift;
|
||||
my $self;
|
||||
# Hash as argument
|
||||
if (ref($type) eq "HASH") {
|
||||
$self = $type;
|
||||
$type = $self->{type};
|
||||
}
|
||||
croak "Invalid type '",$type,"' given (should be one of ",join(" ",keys %$TYPES),")" unless $TYPES->{$type};
|
||||
|
||||
# Hash comes after type
|
||||
if (!$self) {
|
||||
if (ref($_[0]) eq "HASH") {
|
||||
$self = $_[0];
|
||||
$self->{type} = $type;
|
||||
} else {
|
||||
# Unnamed arguments
|
||||
$self = {type => $type};
|
||||
|
||||
# Options are given as last part
|
||||
my $opts = $_[scalar(@_)-1];
|
||||
if (ref($opts) eq "HASH") {
|
||||
pop @_;
|
||||
map { $self->{$_} = $opts->{$_} } keys %$opts;
|
||||
if ($self->{method}) {
|
||||
# Canonicalize and verify
|
||||
method($self,$self->{method});
|
||||
}
|
||||
}
|
||||
if ($type eq READ) {
|
||||
$self->{mbean} = shift;
|
||||
$self->{attribute} = shift;
|
||||
$self->{path} = shift;
|
||||
# Use post for complex read requests
|
||||
if (ref($self->{attribute}) eq "ARRAY") {
|
||||
my $method = method($self);
|
||||
if (defined($method) && $method eq "GET") {
|
||||
# Was already explicitely set
|
||||
die "Cannot query for multiple attributes " . join(",",@{$self->{attributes}}) . " with a GET request"
|
||||
if ref($self->{attribute}) eq "ARRAY";
|
||||
}
|
||||
method($self,"POST");
|
||||
}
|
||||
} elsif ($type eq WRITE) {
|
||||
$self->{mbean} = shift;
|
||||
$self->{attribute} = shift;
|
||||
$self->{value} = shift;
|
||||
$self->{path} = shift;
|
||||
} elsif ($type eq EXEC) {
|
||||
$self->{mbean} = shift;
|
||||
$self->{operation} = shift;
|
||||
$self->{arguments} = [ @_ ];
|
||||
} elsif ($type eq LIST) {
|
||||
$self->{path} = shift;
|
||||
} elsif ($type eq SEARCH) {
|
||||
$self->{mbean} = shift;
|
||||
#No check here until now, is done on the server side as well.
|
||||
#die "MBean name ",$self->{mbean}," is not a pattern" unless is_mbean_pattern($self);
|
||||
} elsif ($type eq AGENT_VERSION) {
|
||||
# No extra parameters required
|
||||
} else {
|
||||
croak "Type ",$type," not supported yet";
|
||||
}
|
||||
}
|
||||
}
|
||||
bless $self,(ref($class) || $class);
|
||||
$self->_validate();
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item $req->method()
|
||||
|
||||
=item $req->method("POST")
|
||||
|
||||
Set the HTTP request method for this requst excplicitely. If not provided
|
||||
either during construction time (config key 'method') a prefered request
|
||||
method is determined dynamically based on the request contents.
|
||||
|
||||
=cut
|
||||
|
||||
sub method {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined($value)) {
|
||||
die "Unknown request method ",$value if length($value) && uc($value) !~ /^(POST|GET)$/i;
|
||||
$self->{method} = uc($value);
|
||||
}
|
||||
return defined($self->{method}) ? $self->{method} : undef;
|
||||
}
|
||||
|
||||
=item $req->is_mbean_pattern
|
||||
|
||||
Returns true, if the MBean name used in this request is a MBean pattern (which
|
||||
can be used in C<SEARCH> or for C<READ>) or not
|
||||
|
||||
=cut
|
||||
|
||||
sub is_mbean_pattern {
|
||||
my $self = shift;
|
||||
my $mbean = shift || $self->{mbean};
|
||||
return 1 unless $mbean;
|
||||
my ($domain,$rest) = split(/:/,$mbean,2);
|
||||
return 1 if $domain =~ /[*?]/;
|
||||
return 1 if $rest =~ /\*$/;
|
||||
|
||||
while ($rest) {
|
||||
#print "R: $rest\n";
|
||||
$rest =~ s/([^=]+)\s*=\s*//;
|
||||
my $key = $1;
|
||||
my $value;
|
||||
if ($rest =~ /^"/) {
|
||||
$rest =~ s/("(\\"|[^"])+")(\s*,\s*|$)//;
|
||||
$value = $1;
|
||||
# Pattern in quoted values must not be preceded by a \
|
||||
return 1 if $value =~ /(?<!\\)[\*\?]/;
|
||||
} else {
|
||||
$rest =~ s/([^,]+)(\s*,\s*|$)//;
|
||||
$value = $1;
|
||||
return 1 if $value =~ /[\*\?]/;
|
||||
}
|
||||
#print "K: $key V: $value\n";
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
=item $request->get("type")
|
||||
|
||||
Get a request parameter
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
return $self->{$name};
|
||||
}
|
||||
|
||||
# Internal check for validating that all arguments are given
|
||||
sub _validate {
|
||||
my $self = shift;
|
||||
if ($self->{type} eq READ || $self->{type} eq WRITE) {
|
||||
die $self->{type} . ": No mbean name given\n",Dumper($self) unless $self->{mbean};
|
||||
die $self->{type} . ": No attribute name but path is given\n" if (!$self->{attribute} && $self->{path});
|
||||
}
|
||||
if ($self->{type} eq WRITE) {
|
||||
die $self->{type} . ": No value given\n" unless defined($self->{value});
|
||||
}
|
||||
if ($self->{type} eq EXEC) {
|
||||
die $self->{type} . ": No mbean name given\n" unless $self->{mbean};
|
||||
die $self->{type} . ": No operation name given\n" unless $self->{operation};
|
||||
}
|
||||
}
|
||||
|
||||
# Called for post requests
|
||||
sub TO_JSON {
|
||||
my $self = shift;
|
||||
my $ret = {
|
||||
type => $self->{type} ? uc($self->{type}) : undef,
|
||||
};
|
||||
for my $k (qw(mbean attribute path value operation arguments target)) {
|
||||
$ret->{$k} = $self->{$k} if defined($self->{$k});
|
||||
}
|
||||
my %config;
|
||||
for my $k (qw(maxDepth maxObjects maxCollectionSize ignoreErrors)) {
|
||||
$config{$k} = $self->{$k} if defined($self->{$k});
|
||||
}
|
||||
$ret->{config} = \%config if keys(%config);
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
180
lib/JMX/Jmx4Perl/Response.pm
Normal file
180
lib/JMX/Jmx4Perl/Response.pm
Normal file
@@ -0,0 +1,180 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Response - A jmx4perl response
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $jmx_response = $jmx_agent->request($jmx_request);
|
||||
my $value = $jmx_response->value();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A L<JMX::Jmx4Perl::Response> is the result of an JMX request and encapsulates
|
||||
the answer as returned by a L<JMX::Jmx4Perl> backend. Depending on the
|
||||
C<status> it either contains the result of a valid request or a error message.
|
||||
The status is modelled after HTTP response codes (see
|
||||
L<http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html>). For now, only the
|
||||
codes C<200> and C<400 .. 599> codes are used to specified successful request
|
||||
and errors respectively.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
package JMX::Jmx4Perl::Response;
|
||||
|
||||
use strict;
|
||||
use vars qw(@EXPORT);
|
||||
|
||||
=item $response = JMX::Jmx4Perl::Response->new($status,$request,$value,$error,$stacktrace)
|
||||
|
||||
Internal constructor for creating a response which is use withing requesting
|
||||
the backend. C<$error> and C<$stacktrace> are optional and should only provided
|
||||
when C<$status != 200>.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = { @_ };
|
||||
return bless $self,(ref($class) || $class);
|
||||
}
|
||||
|
||||
=item $status = $response->status()
|
||||
|
||||
Return the status code of this response. Status codes are modelled after HTTP
|
||||
return codes. C<200> is the code for a suceeded request. Any code in the range
|
||||
500 - 599 specifies an error.
|
||||
|
||||
=cut
|
||||
|
||||
sub status {
|
||||
return shift->{status};
|
||||
}
|
||||
|
||||
=item $timestamp = $response->timestamp()
|
||||
|
||||
Get the timestamp (i.e. epoch seconds) when the request was executed on the
|
||||
serverside.
|
||||
|
||||
=cut
|
||||
|
||||
sub timestamp {
|
||||
return shift->{timestamp};
|
||||
}
|
||||
|
||||
=item $history = $response->history()
|
||||
|
||||
Get the history if history tracking is switched on. History tracking is
|
||||
switchen on by executing a certain JMX operation on the C<jolokia:type=Config>
|
||||
MBean. See the alias C<JMX4PERL_HISTORY_MAX_ATTRIBUTE> and L<jmx4perl/"HISTORY
|
||||
TRACKING"> for details.
|
||||
|
||||
The returned arrayref (if any) contains hashes with two values: C<value>
|
||||
contains the historical value and C<timestamp> the timestamp when this value
|
||||
was recorded.
|
||||
|
||||
=cut
|
||||
|
||||
sub history {
|
||||
return shift->{history};
|
||||
}
|
||||
|
||||
=item $ok = $response->is_ok()
|
||||
|
||||
Return true if this object contains a valid response (i.e. the status code is
|
||||
equal 200)
|
||||
|
||||
=cut
|
||||
|
||||
sub is_ok {
|
||||
return shift->{status} == 200;
|
||||
}
|
||||
|
||||
=item $fault = $response->is_error()
|
||||
|
||||
Opposite of C<is_ok>, i.e. return true if the status code is B<not> equal to
|
||||
200
|
||||
|
||||
=cut
|
||||
|
||||
sub is_error {
|
||||
return shift->{status} != 200;;
|
||||
}
|
||||
|
||||
=item $error = $response->error_text()
|
||||
|
||||
Return the error text. Set only if C<is_error> is C<true>
|
||||
|
||||
=cut
|
||||
|
||||
sub error_text {
|
||||
return shift->{error};
|
||||
}
|
||||
|
||||
=item $error = $response->stacktrace()
|
||||
|
||||
Returns the stacktrace of an Java error if any. This is only set when
|
||||
C<is_error> is C<true> B<and> and Java exception occured on the Java agent's
|
||||
side.
|
||||
|
||||
=cut
|
||||
|
||||
sub stacktrace { return shift->{stacktrace}; }
|
||||
|
||||
=item $content = $response->value()
|
||||
|
||||
Return the content of this response, which is a represents the JSON response as
|
||||
returned by the Java agent as a hash reference value. This is set only when C<is_ok> is
|
||||
true.
|
||||
|
||||
=cut
|
||||
|
||||
sub value {
|
||||
return shift->{value};
|
||||
}
|
||||
|
||||
=item $request = $response->request()
|
||||
|
||||
Return the L<JMX::Jmx4Perl::Request> which lead to this response
|
||||
|
||||
=cut
|
||||
|
||||
sub request {
|
||||
return shift->{request};
|
||||
}
|
||||
|
||||
=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 AUTHOR
|
||||
|
||||
roland@cpan.org
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
1;
|
||||
132
lib/JMX/Jmx4Perl/Util.pm
Normal file
132
lib/JMX/Jmx4Perl/Util.pm
Normal file
@@ -0,0 +1,132 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JMX::Jmx4Perl::Util - Utility methods for Jmx4Perl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class contains utility methods mostly for tools like C<jmx4perl> or
|
||||
C<j4psh> for things like formatting data output. All methods are 'static'
|
||||
methods which needs to be called like in
|
||||
|
||||
JMX::Jmx4Perl::Util->dump_value(...);
|
||||
|
||||
There is no constructor.
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
package JMX::Jmx4Perl::Util;
|
||||
|
||||
use Data::Dumper;
|
||||
use JSON;
|
||||
|
||||
=item $is_object = JMX::Jmx4Perl::Util->is_object_to_dump($val)
|
||||
|
||||
For dumping out, checks whether C<$val> is an object (i.e. it is a ref but not a
|
||||
JSON::XS::Boolean) or not.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_object_to_dump {
|
||||
my $self = shift;
|
||||
my $val = shift;
|
||||
return ref($val) && !JSON::is_bool($val);
|
||||
}
|
||||
|
||||
=item $text = JMX::Jmx4Perl::Util->dump_value($value,{ format => "json", boolean_string =>1})
|
||||
|
||||
Return a formatted text representation useful for tools printing out complex
|
||||
response values. Two modes are available: C<data> which is the default and uses
|
||||
L<Data::Dumper> for creating a textual description and C<json> which return the
|
||||
result as JSON value. When C<data> is used as format, booleans are returned as 0
|
||||
for false and 1 for true exception when the option C<boolean_string> is given in
|
||||
which case it returns C<true> or C<false>.
|
||||
|
||||
=cut
|
||||
|
||||
sub dump_value {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
my $opts = shift || {};
|
||||
if ($opts && ref($opts) ne "HASH") {
|
||||
$opts = { $opts,@_ };
|
||||
}
|
||||
my $format = $opts->{format} || "data";
|
||||
my $ret;
|
||||
if ($format eq "json") {
|
||||
# Return a JSON representation of the data structure
|
||||
my $json = JSON->new->allow_nonref;
|
||||
$ret = $json->pretty->encode($value);
|
||||
} else {
|
||||
# Use data dumper, but resolve all JSON::XS::Booleans to either 0/1 or
|
||||
# true/false
|
||||
local $Data::Dumper::Terse = 1;
|
||||
local $Data::Dumper::Indent = 1;
|
||||
# local $Data::Dumper::Useqq = 1;
|
||||
local $Data::Dumper::Deparse = 0;
|
||||
local $Data::Dumper::Quotekeys = 0;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
$ret = Dumper($self->_canonicalize_value($value,$opts->{booleans}));
|
||||
}
|
||||
my $indent = $opts->{indent} ? " " x $opts->{indent} : " ";
|
||||
$ret =~ s/^/$indent/gm;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=item $dump = JMX::Jmx4Perl::Util->dump_scalar($val,$format)
|
||||
|
||||
Dumps a scalar value with special handling for booleans. If C<$val> is a
|
||||
L<JSON::XS::Boolean> it is returned as string formatted according to
|
||||
C<$format>. C<$format> must contain two values separated bu C</>. The first
|
||||
part is taken for a C<true> value, the second for a C<false> value. If no
|
||||
C<$format> is given, C<[true]/[false]> is used.
|
||||
|
||||
=cut
|
||||
|
||||
sub dump_scalar {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
my $format = shift || "[true]/[false]";
|
||||
|
||||
if (JSON::is_bool($value)) {
|
||||
my ($true,$false) = split /\//,$format;
|
||||
if ($value eq JSON::true) {
|
||||
return $true;
|
||||
} else {
|
||||
return $false;
|
||||
}
|
||||
} else {
|
||||
return $value;
|
||||
}
|
||||
}
|
||||
|
||||
# Replace all boolean values in
|
||||
sub _canonicalize_value {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
my $booleans = shift;
|
||||
if (ref($value) eq "HASH") {
|
||||
for my $k (keys %$value) {
|
||||
$value->{$k} = $self->_canonicalize_value($value->{$k},$booleans);
|
||||
}
|
||||
return $value;
|
||||
} elsif (ref($value) eq "ARRAY") {
|
||||
for my $i (0 .. $#$value) {
|
||||
$value->[$i] = $self->_canonicalize_value($value->[$i],$booleans);
|
||||
}
|
||||
return $value;
|
||||
} elsif (JSON::is_bool($value)) {
|
||||
$self->dump_scalar($value,$booleans);
|
||||
} else {
|
||||
return $value;
|
||||
}
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user