#!/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;
$self->_check_mbean($domain,$mbean);
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 $mbean = shift;
my $context = $self->context;
return $context->mbeans_by_name->{$domain . ":" . $mbean};
}
# 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;