debmon/jmx4perl
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Imported Upstream version 1.12

Browse Source
This commit is contained in:
Mario Fetka
2017-10-31 14:38:28 +01:00
commit ae1fc8494f
157 changed files with 35016 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

294
lib/JMX/Jmx4Perl/J4psh/Command.pm Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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;