jmx4perl/lib/JMX/Jmx4Perl/J4psh.pm

328 lines
8.0 KiB
Perl
Raw Normal View History

2017-10-31 14:38:28 +01:00
#!/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;