#!/usr/bin/perl

=head1 NAME

jmx4perl - JMX access tools and modules

=cut

use Getopt::Long;
use FindBin;
use lib "$FindBin::Bin/../lib";
use JMX::Jmx4Perl;
use JMX::Jmx4Perl::Request;
use JMX::Jmx4Perl::Alias;
use strict;
use Carp;
use Data::Dumper;

my %COMMANDS = 
  (
   info => \&command_info,
   list => \&command_list,
   attributes => \&command_attributes,
   read => \&command_read,
   get => \&command_read,
   write => \&command_write,
   set => \&command_write,
   exec => \&command_exec,
   call => \&command_exec,
   search => \&command_search
);

my %opts = ();
my $result = GetOptions(\%opts,
                        "user|u=s","password|p=s",
                        "proxy=s",
                        "proxy-user=s","proxy-password=s",
                        "target|t=s","target-user=s","target-password=s",
                        "product=s",
                        "config=s",
                        "verbose|v!",
                        "shell|s=s",
                        "version!",
                        "history!",
                        "help|h!" => sub { &Getopt::Long::HelpMessage() }
                       );

if ($opts{version}) {
    print "jmx4perl ",$JMX::Jmx4Perl::VERSION,"\n";
    exit(0);
}

my $url;
my $command;
my @args;
if (!@ARGV) {
    $opts{shell} = 1;
} elsif(lc $ARGV[0] eq "aliases") {
    &command_aliases;
    exit(0);
} elsif (@ARGV == 1) {
    $command = "info";
    $url = $ARGV[0];
} else {
    $url = shift @ARGV;
    $command = lc shift @ARGV;
    @args = ( @ARGV );
}

if ($opts{shell}) {
    print "Interactive shell mode not supported yet.\nPlease provide a command as argument\n\n";
    &Getopt::Long::HelpMessage();
} else {
    my $sub = $COMMANDS{$command} || die "No command '",$command,"' known. See --help for assistance.\n";

    my $jmx_args = &_get_args_for_jmx4perl($url,\%opts);
    my $jmx4perl = new JMX::Jmx4Perl($jmx_args);
    &{$sub}($jmx4perl,@args);
}

=head1 SYNOPSIS

  jmx4perl

  jmx4perl .... --shell http://server:8080/j4p

  jmx4perl .... <agent-url> ["info"] 

  jmx4perl .... <agent-url> read <mbean-name> <attribute-name> [path] 

  jmx4perl .... <agent-url> write <mbean-name> <attribute-name> <value> [path]

  jmx4perl .... <agent-url> exec <mbean-name> <operation> <arg1> <arg2> ...

  jmx4perl .... <agent-url> search <mbean pattern>

  jmx4perl .... <agent-url> list 

  jmx4perl .... <agent-url> attributes [max-depth max-list-size max-objects] 

  jmx4perl .... aliases

  jmx4perl --help

  jmx4perl --version

Options:

   --product <id>          Product to use for aliasing (ommits autodetection)
   --user <user>           Credential used for authentication   
   --password <pwd>  
   --proxy <url>           URL to proxy
   --proxy-user <user>     Authentication information for a proxy
   --proxy-password <pwd>
   --target <jmx-url>      JSR-160 JMX Service URL to be used as the target server
   --target-user <user>    Credential for the target server if --target is given
   --target-password <pwd> 
   --config                Path to an optional configuration file (default: ~/.j4p)
   --history               Print out the history of return values (if switched on and present)
   --verbose               Print out more information

=head1 DESCRIPTION

B<jmx4perl> is a command line utility for easily accessing an instrumented
application server. Before you can use this tool, you need to deploy a small
agent application. In the following C<agent-url> is the URL for accessing this
agent. If you use a configuration file, you can use also a symbolic name as
stored in the configuration file. See L<JMX::Jmx4Perl::Manual> for details.

You can use B<jmx4perl> in two modes: Directly by providing an C<agent-url> or
enter an interactive mode if you ommit the agent-url or provide the the
command line options C<--shell> (I<to be done>).

B<jmx4perl> servers also an example of how to use the L<JMX::Jmx4Perl>
package. See its documentation for more details on how to embed JMX access
into your programs.

=cut

# =================================================================================================== 
# Non-interactive commands:

=head1 NON-INTERACTIVE COMMANDS

=head2 info

If you use the non-interactive mode without any command or with C<info> as
command, you get a description about the server, including the application
server's product name and version. This works by autodetection and only for
the supported application servers (see L<JMX::Jmx4Perl::Manual> for a list of
supported products). The only argument required is the url which points to the
deployed jmx4perl agent.

With C<--verbose> C<info> prints the system properties and runtime arguments as
well. 

=cut 

sub command_info {
    my $jmx = shift;
    print $jmx->info($opts{verbose});
}

=head2 list


List meta data of all registered mbeans on the target application server. This
includes attributes and operations along whith their descriptions and
parameters (as far as they are provided by mbean's info).

You can provide an inner path as an additional argument as well. See
L<JMX::Jmx4Perl::Request> for an explanation about inner pathes (in short, it's
some sort of XPath expression which selects only a subset of all MBeans and
their values). See L<JMX::Jmx4Perl>, method "list()" for a more rigorous
documentation abouting listing of MBeans.

=cut

sub command_list {
    my ($jmx,$path) = @_;

    my $req = JMX::Jmx4Perl::Request->new(LIST,$path);
    my $resp = $jmx->request($req);
    &_check_for_error($resp);

    # Show list of beans
    print $jmx->formatted_list($resp);       
}

=head2 attributes 

Show all attributes of all registerd mbeans and their values. For simple scalar
values they are shown on one line, for more complex data structures,
L<Data::Dumper> is used. Please note, that it is normal, that for certain
attributes an error is returned (i.e. when this attribute is not implemented on
the server side e.g. or an MXMbean). To see the full server side stacktrace for
this errors, use C<--verbose> as command line option

The attribute list can get quite large (moren than 200 MB for JBoss 5). To
restrict the output you can use the following extra optional parameters (given
in this order):

=over

=item max_depth

Maximum nesting level of the returned JSON structure for a certain MBean
(default: 5)

=item max_list_size

Maximum size of a collection after which it gets truncated (default: 150)

=item max_objects

Maximum overall objects to fetch for a certain MBean (default: 1000)

=back

In the case of truncation, the JSON answer contains marker entries like
C<[Object limit exceeded]> or C<[Depth limit ...]>. Loops are detected, too
which results in markers of the form C<[Reference ...]>

=cut

sub command_attributes {
    my $jmx = shift;
    my $max_depth = defined($_[0]) ? $_[0] : 4;
    my $max_list_size = defined($_[1]) ? $_[1] : 150;
    my $max_objects = defined($_[2]) ? $_[2] : 1000;
    my $data = $jmx->list();
    
    for my $d (keys %$data) {
        for my $p (keys %{$data->{$d}}) {
            my $attrs = $data->{$d}->{$p}->{'attr'};
            if ($attrs) {
                for my $a (keys %{$attrs}) {
                    print "$d:$p -- $a";
					eval {
						my $request = JMX::Jmx4Perl::Request->new(READ,$d . ":" . $p,$a,{max_depth => $max_depth,
                                                                                         max_objects => $max_objects,
                                                                                         max_list_size => $max_list_size});
                        my $response = $jmx->request($request);
                        if ($response->is_error) {                            
                            print "\nERROR: ",$response->error_text,"\n";
                            if ($opts{verbose}) {
                                if ($response->stacktrace) {
                                    print $response->stacktrace;
                                } else {
                                    print Dumper($response);
                                }
                            }
                        } else {
                            my $val = $response->value;
                            if (ref($val)) {
                                print "\n   ",Dumper($val);
                            } else {
                                print " = ",$val,"\n";
                            }
                        }
                    };
                    if ($@) {
                        print "\nERROR: ",$@,"\n";
                    }
                }
            }
        }
    }   
}

=head2 read / get

Read an JMX attribute's value and print it out. The required arguments are the
MBean's name and the attribute's name. Additionally, you can provide a I<path>
within the return value to pick a sub-value. See L<JMX::Jmx4Perl::Request> for a
detailed explanation of pathes.

The MBean's name and the attribute can be substituted by an
alias name, too.

For a single value, the value itself is printed (without additional newline),
for a more complex data structure, L<Data::Dumper> is used. 

If the option C<--history> is given and history tracking is switched on (see
below), then the stored history is printed as well.

=cut 

sub command_read {
    my $resp = &_get_attribute(@_);    
    &_check_for_error($resp);    
    &_print_response($resp);
}

=head2 write / set

Write a JMX attribute's value and print out the value as it is returned from
the server. The required arguments are the MBean's name, the attribute and the
value to set. Optionally, a inner path can be provided as well in which case a
inner value is set. The MBean's name and the attribute can be substituted by an
alias name, too. See also L</"aliases"> for getting all available aliases.

The old value of the attribute (or the object pointed to by the inner path) is
printed out in the same as for L</"read">

To set a C<null> value use "[null]" as argument, to set an empty string use an
empty argument (i.e. C<""> on the command line). These values are interpreted
special, so you can't use them literally as values.

If the option C<--history> is given and history tracking is switched on (see
below), then the stored history is printed as well.

=cut

sub command_write {
    my $resp = &_set_attribute(@_);
    &_check_for_error($resp);
    &_print_response($resp);
}

=head2 exec / call

Execute a JMX operation. The required arguments are the MBean's name, the name
of the operation to execute and the arguments required for this operations
(which can be empty if the operation doesn't take any arguments). The return
value is the return value of the operation which can be C<undef> in the case of
a void operation.

A operation alias can also be used for the MBean's name and operation.

To use a C<null> argument use "[null]", to set an empty string as argument use
an empty argument (i.e. C<"">) on the command line. These values are
interpreted special, so you can't use them literally as values.

For a single return value, the value itself is printed (without additional
newline), for a more complex data structure, L<Data::Dumper> is used.

If the option C<--history> is given and history tracking is switched on (see
below), then the stored history is printed as well.

=cut

sub command_exec {
    my $resp = &_exec_operation(@_);
    &_check_for_error($resp);
    &_print_response($resp);    
}

=head2 aliases 

Print out all known aliases. See L<JMX::Jmx4Perl::Manual> for a discussion
about aliases. In short, you can use an alias as a shortcut for an MBean's
and attribute's name.

=cut

sub command_aliases {
    &JMX::Jmx4Perl::Alias::help;
}

=head2 search

Search for a certain MBean. As argument you should provide a pattern like
C<*:*,j2eeType=Servlet,*>. I.e you can use the wildcard C<*> for the domain
name part, and properties as a whole (but not within a key=property tuple). See
L<http://java.sun.com/j2se/1.5.0/docs/api/javax/management/ObjectName.html> for
a complete explanation of how a pattern can look like. As a result of this
operation, a list of fully qualified MBean names is printed out line by line
which match the given pattern. 

=cut

sub command_search {
    my $resp = &_search_attribute(@_);
    return if $resp->status == 404;
    &_check_for_error($resp);
    my $val = $resp->value;
    $val = [ $val ] unless ref($val) eq "ARRAY";
    for my $l (@$val) {
        print $l,"\n";
    }
}

=head1 HISTORY TRACKING

The agent j4p knows about a history mode, which can remember a certain
amount return values from previous requests. This mode can be switched on/off
on a per attribute (+ inner path) and operation basis. By default it is
switched off completely. You can switch in on by executing the
C<JMX4PERL_HISTORY_MAX_ATTRIBUTE> and C<JMX4PERL_HISTORY_MAX_OPERATION>
operation with L</"exec"> commands. This is best explained by some example:

 jmx4perl exec JMX4PERL_HISTORY_MAX_ATTRIBUTE java.lang:type=Memory HeapMemoryUsage used 10 <agent-url>

This switches on tracking of this particular attribute. I.e. each time a
C<read> request is performed, the value is remembered along with a timestamp on
the server side. At maximum 10 entries are kept, the oldest entries get shifted
out after the eleventh read. Setting the value to C<0> will remove the history
completely. You can't set the limit beyond a certain hard limit, which can be
found as attribute under the alias
C<JMX4PERL_HISTORY_MAX_ENTRIES>. Unfortunately, one can not use an alias yet
for the arguments of C<JMX4PERL_HISTORY_MAX_ATTRIBUTE>. Also note, if you don't
has an inner path, you need to use a C<[null]> as the argument before the max
entry number.

For completely resetting the history, use

 jmx4perl exec JMX4PERL_HISTORY_RESET <agent-url>

If you are curious about the size of the history for all entries, use 

 jmx4perl read JMX4PERL_HISTORY_SIZE <agent-url>

This will print out the history size in bytes.

=cut

# =============================================================================

sub _check_for_error { 
    my $resp = shift;
    if ($resp->is_error) {
        print STDERR "ERROR: ",$resp->error_text,"\n";
        if ($opts{verbose}) {
            if ($resp->stacktrace) {
                print STDERR "Server Stacktrace:\n";
                print STDERR $resp->stacktrace;
            }
        }
        exit 1;
    }
}

sub _has_tty {
  return -t STDOUT;
}

sub _print_response {
    my $resp = shift;
    my $val = $resp->value;
    if (ref($val)) {
        print Dumper($val);
    } else {
        print $val;
        print "\n" if &_has_tty;
    }
    if ($opts{history} && $resp->history) {
        print "\nHistory:\n";
        for my $entry (@{$resp->history}) {
            my $time = localtime($entry->{timestamp});
            my $value = $entry->{value};
            if (ref($value)) {
                print $time,"\n";
                print Dumper($value);
                print "\n";
            } else {
                printf " %s : %s\n",$time,$value;
            }
        }
    }
}

sub _get_attribute {
    my $jmx = shift;
    my ($mbean,$attribute,$path) = _extract_get_set_parameter($jmx,"get",@_);
    if (ref($mbean) eq "CODE") {
        return $jmx->delegate_to_handler($mbean,@args);
    }

    my $req = new JMX::Jmx4Perl::Request(READ,$mbean,$attribute,$path);
    return $jmx->request($req);
}

sub _set_attribute {
    my $jmx = shift;
    my ($mbean,$attribute,$path,$value) = _extract_get_set_parameter($jmx,"set",@_);
    if (ref($mbean) eq "CODE") {
        return $jmx->delegate_to_handler($mbean,@args);
    }

    my $req = new JMX::Jmx4Perl::Request(WRITE,$mbean,$attribute,$value,$path);
    return $jmx->request($req);
}

sub _search_attribute {
    my $jmx = shift;
    my ($pattern) = @_;
    my $req = new JMX::Jmx4Perl::Request(SEARCH,$pattern);
    return $jmx->request($req);
}

sub _exec_operation {
    my $jmx = shift;
    my ($mbean,$operation,@args) = @_;    
    my $alias = JMX::Jmx4Perl::Alias->by_name($mbean);    
    if ($alias) {
        croak $alias->{alias}, " is not an operation alias" unless $alias->{type} eq "operation";
        unshift @args,$operation if $operation;
        ($mbean,$operation) = $jmx->resolve_alias($alias);
        if (ref($mbean) eq "CODE") {
            return $jmx->delegate_to_handler($mbean,@args);
        }
        die "Alias ",$alias->{alias}," is not available for product ",$jmx->product,"\n" unless $mbean;
    } else {
        &_validate_mbean_name($mbean);
        die "ERROR No operation given for MBean $mbean given\n" unless $operation;
    }    
    print "$mbean $operation\n";
    my $req = new JMX::Jmx4Perl::Request(EXEC,$mbean,$operation,@args);
    return $jmx->request($req);
}


sub _extract_get_set_parameter {
    my ($jmx,$mode,$mbean,$attribute,$path_or_value,$path) = @_;
    my $value;
    $path = $path_or_value if $mode eq "get";
    $value = $path_or_value if $mode eq "set";

    croak "No MBean name or alias given\n" unless $mbean;

    # Try to resolve the MBean name as an alias. If this works, we are using
    # this alias.
    my $alias = JMX::Jmx4Perl::Alias->by_name($mbean);
    if ($alias) {
        # Shift arguments
        $path = $attribute if $mode eq "get";  # path comes after alias
        if ($mode eq "set") {
            $path = $value;
            $value = $attribute;
        }
        my ($o,$a,$p) = $jmx->resolve_alias($alias);
        die "Alias ",$alias->{alias}," is not available for product ",$jmx->product,"\n" unless $o;
        if ($path) {
            $p = $p ? $p . "/" . $path : $path;
        }
        return ($o,$a,$p,$value);
    } else {
        &_validate_mbean_name($mbean);
        die "ERROR No attribute for MBean $mbean given\n" unless $attribute;
        return ($mbean,$attribute,$path,$value);
    }    
}

sub _validate_mbean_name {
    my $mbean = shift;
    die "ERROR: Invalid format for MBean name $mbean (Did you misspelled an alias name ?)\n" if 
      ($mbean !~ /^[^:]+:[^:]+$/ || $mbean !~ /:([^=]+)=/);    
}

sub _get_args_for_jmx4perl {
    my $url = shift;
    my $opts = shift;
    # Try provided first argument as server name first in a 
    # given configuration
    my $ret;
    my $config = new JMX::Jmx4Perl::Config($opts->{config});
    my $server_config = $config->get_server_config($url);
    if ($server_config && $server_config->{url}) {
        print "Taking ",$server_config->{url}, " from configuration for $url\n" if $opts->{verbose};
        &_verify_url($server_config->{url});
        # Use server configs as default
        $ret = { server => $url, config => $config };
    } else {
        &_verify_url($url);
        $ret = { url => $url };
    }

    for my $arg qw(product user password verbose) {
        my $cfg = $arg;
        $cfg =~ s/\-/_/g;
        if (defined($opts->{$arg})) {
            $ret->{$cfg} = $opts->{$arg};
        }
    }
    if (defined($opts->{proxy})) {
        # Already set in server config ?
        die "Old proxy syntax (Proxy,Proxy_User,Proxy_Password) not supported in config anymore" 
          unless ref($opts->{proxy}) eq "HASH";
        my $proxy = $ret->{proxy} || {};
        $proxy->{url} = $opts->{proxy};
        for my $k (qw(user password)) {
            $proxy->{$k} = defined($opts->{'proxy-' . $k}) ? $opts->{'proxy-' . $k} : $proxy->{$k};
            delete $proxy->{$k} unless $proxy->{$k};
        }
        $ret->{proxy} = $proxy;
    }
    if (defined($opts->{target})) {
        $ret->{target} = {
                          url => $opts->{target},
                          $opts->{'target-user'} ? (user => $opts->{'target-user'}) : (),
                          $opts->{'target-password'} ? (password => $opts->{'target-password'}) : (),
                         };
    }
    return $ret;
}

sub _verify_url {
    my $url = shift;
    
    unless ($url =~ m|^\w+://|) {
        my $text = "No url or server name given for command. See --help for assistance.\n";
        my $last = $#ARGV >= 0 ? $ARGV[$#ARGV] : undef;
        if ($last && $last =~ m|^\w+://| && $last ne $url) {
            $text .= "Please note, that the URL must be given as first argument, not as last.\n";
        }
        die $text;
    }
}

=head1 SHELL MODE

I<Some ideas for the interactive mode, which needs still to be implemented: >

=over 

=item * 

Readline support 

=item *

TAB completion of MBean names, attributes and operations

=item * 

Autodetection of various application servers

=item * 

Reading and writing of attributes

=item * 

Excecution of MBean operations

=back

=head1 SEE ALSO

L<JMX::Jmx4Perl> - Entry point for programmatic JMX access which is used by
this tool.

L<check_jmx4perl> - a production ready Nagios check using L<JMX::Jmx4Perl>

=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
