1#!/usr/bin/perl
2
3package JMX::Jmx4Perl::J4psh;
4
5use JMX::Jmx4Perl::J4psh::CompletionHandler;
6use JMX::Jmx4Perl::J4psh::ServerHandler;
7use JMX::Jmx4Perl::J4psh::CommandHandler;
8use JMX::Jmx4Perl::J4psh::Shell;
9use JMX::Jmx4Perl::Request;
10use JMX::Jmx4Perl;
11use Data::Dumper;
12use strict;
13
14=head1 NAME
15
16JMX::Jmx4Perl::J4psh - Central object for the JMX shell j4psh
17
18=cut
19
20sub new {
21    my $class = shift;
22    my $self = ref($_[0]) eq "HASH" ? $_[0] : {  @_ };
23    bless $self,(ref($class) || $class);
24    $self->init();
25    return $self;
26}
27
28sub init {
29    my $self = shift;
30    $self->{complete} = new JMX::Jmx4Perl::J4psh::CompletionHandler($self);
31    $self->{servers} = new JMX::Jmx4Perl::J4psh::ServerHandler($self);
32    $self->{shell} = new JMX::Jmx4Perl::J4psh::Shell(config => $self->config->{shell},args => $self->args);;
33    my $no_color_prompt = $self->{shell}->readline ne "Term::ReadLine::Gnu";
34    $self->{commands} = new JMX::Jmx4Perl::J4psh::CommandHandler($self,$self->{shell},
35                                                                 no_color_prompt => $no_color_prompt,
36                                                                 command_packages => $self->command_packages);
37}
38
39sub command_packages {
40    return [ "JMX::Jmx4Perl::J4psh::Command" ];
41}
42
43sub run {
44    my $self = shift;
45    $self->{shell}->run;
46}
47
48sub config {
49    return shift->{config};
50}
51
52sub args {
53    return shift->{args};
54}
55
56sub complete {
57    return shift->{complete};
58}
59
60sub commands {
61    return shift->{commands};
62}
63
64sub servers {
65    return shift->{servers};
66}
67
68sub server {
69    return shift->{servers}->{server};
70}
71
72sub color {
73    return shift->{shell}->color(@_);
74}
75
76sub term_height {
77    return shift->{shell}->term_height;
78}
79
80sub term_width {
81    return shift->{shell}->term_width;
82}
83
84sub agent {
85    my $self = shift;
86    my $agent = shift;
87    if (defined($agent)) {
88        $self->{agent} = $agent;
89    }
90    return $self->{agent};
91}
92
93sub last_error {
94    my $self = shift;
95    my $error = shift;
96    if (defined($error)) {
97        if (length($error)) {
98            $self->{last_error} = $error;
99        } else {
100            delete $self->{last_error};
101        }
102    }
103    return $self->{last_error};
104}
105
106sub create_agent {
107    my $self = shift;
108    my $args = shift;
109    my $j4p = new JMX::Jmx4Perl($args);
110    $self->load_list($j4p);
111    $self->_legacy_check($j4p);
112    $self->agent($j4p);
113    return $j4p;
114}
115
116sub load_list {
117    my $self = shift;
118    my $j4p = shift;
119
120    my $old_list = $self->{list};
121    eval {
122        my $req = new JMX::Jmx4Perl::Request(LIST);
123        $self->{list} = $self->request($req,$j4p);
124        ($self->{mbeans_by_domain},$self->{mbeans_by_name}) = $self->_prepare_mbean_names($j4p,$self->{list});
125    };
126    if ($@) {
127        $self->{list} = $old_list;
128        die $@;
129    }
130};
131
132sub _legacy_check {
133    my $self = shift;
134    my $j4p = shift;
135    my $resp = $j4p->version;
136    my $version = $resp->{agent};
137    $version =~ s/^(\d+(\.\d+)).*$/$1/;
138    if ($version < 1.0) {
139        $j4p->cfg('legacy-escape',1);
140    }
141}
142
143sub list {
144
145    return shift->{list};
146}
147
148sub mbeans_by_domain {
149    return shift->{mbeans_by_domain};
150}
151
152sub mbeans_by_name {
153    return shift->{mbeans_by_name};
154}
155
156sub search_mbeans {
157    my $self = shift;
158    my $pattern = shift;
159    $pattern = quotemeta($pattern);
160    $pattern =~ s/\\?\*/.*/g;
161    my @ret = ();
162    my $mbeans_by_name = $self->mbeans_by_name();
163    for my $name (sort keys %$mbeans_by_name) {
164        push @ret,$mbeans_by_name->{$name} if $name =~ /$pattern/
165    }
166    return \@ret;
167}
168
169sub request {
170    my $self = shift;
171    my $request = shift;
172    my $j4p = shift || $self->agent;
173
174    my $response = $j4p->request($request);
175    if ($response->is_error) {
176        #print Dumper($response);
177        if ($response->status == 404) {
178            die "No agent running [Not found: ",$request->{mbean},",",$request->{operation},"].\n"
179        } else {
180            $self->{last_error} = $response->{error} .
181              ($response->stacktrace ? "\nStacktrace:\n" . $response->stacktrace : "");
182            die $self->_prepare_error_message($response) . ".\n";
183        }
184    }
185    return $response->value;
186}
187
188sub _prepare_error_message {
189    my $self = shift;
190    my $resp = shift;
191    my $st = $resp->stacktrace;
192    return "Connection refused" if $resp->{error} =~ /Connection\s+refused/i;
193
194    if ($resp->{error} =~ /^(\d{3} [^\n]+)\n/m) {
195        return $1;
196    }
197    return "Server Error: " . $resp->{error};
198}
199
200
201sub name {
202    return "j4psh";
203}
204
205
206# =========================================
207
208
209sub _prepare_mbean_names {
210    my $self = shift;
211    my $j4p = shift;
212    my $list = shift;
213    my $mbeans_by_name = {};
214    my $mbeans_by_domain = {};
215    for my $domain (keys %$list) {
216        for my $name (keys %{$list->{$domain}}) {
217            my $full_name = $domain . ":" . $name;
218
219            my $e = {};
220            my ($domain_p,$props) = $j4p->parse_name($full_name,1);
221            $e->{domain} = $domain;
222            $e->{props} = $props;
223            $e->{info} = $list->{$domain}->{$name};
224            my $keys = $self->_canonical_ordered_keys($props);
225            $e->{string} = join ",", map { $_ . "=" . $props->{$_ } } @$keys;
226            $e->{prompt} = length($e->{string}) > 25 ?  $self->_prepare_prompt($props,25,$keys) : $e->{string};
227            $e->{full} = $full_name;
228
229            $mbeans_by_name->{$full_name} = $e;
230            my $k_v = $mbeans_by_domain->{$domain} || [];
231            push @$k_v,$e;
232            $mbeans_by_domain->{$domain} = $k_v;
233        }
234    }
235    return ($mbeans_by_domain,$mbeans_by_name);
236}
237
238# Order keys according to importance first and the alphabetically
239my @PREFERED_PROPS = qw(name type service);
240sub _order_keys {
241    my $self = shift;
242    my $props = shift;
243
244    # Get additional properties, not known to the prefered ones
245    my $extra = { map { $_ => 1 } keys %$props };
246    my @ret = ();
247    for my $p (@PREFERED_PROPS) {
248        if (exists($props->{$p})) {
249            push @ret,$p;
250            delete $extra->{$p};
251        }
252    }
253    push @ret,sort keys %{$extra};
254    return \@ret;
255}
256
257# Canonical ordered means lexically sorted
258sub _canonical_ordered_keys {
259    my $self = shift;
260    my $props = shift;
261    return [ sort keys %{$props} ];
262}
263
264# Prepare property part of a mbean suitable for using in
265# a shell prompt
266sub _prepare_prompt {
267    my $self = shift;
268    my $props = shift;
269    my $max = shift;
270    my $keys = shift;
271    my $len = $max - 3;
272    my $ret = "";
273
274    for my $k (@$keys) {
275        if (exists($props->{$k})) {
276            my $p = $k . "=" . $props->{$k};
277            if (!length($ret)) {
278                $ret = $p;
279                if (length($ret) > $max) {
280                    return substr($ret,0,$len) . "...";
281                }
282            } else {
283                if (length($ret) + length($p) > $len) {
284                    return $ret . ", ...";
285                } else {
286                    $ret .= "," . $p;
287                }
288            }
289        }
290    }
291
292}
293
294=head1 LICENSE
295
296This file is part of jmx4perl.
297
298Jmx4perl is free software: you can redistribute it and/or modify
299it under the terms of the GNU General Public License as published by
300the Free Software Foundation, either version 2 of the License, or
301(at your option) any later version.
302
303jmx4perl is distributed in the hope that it will be useful,
304but WITHOUT ANY WARRANTY; without even the implied warranty of
305MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
306GNU General Public License for more details.
307
308You should have received a copy of the GNU General Public License
309along with jmx4perl.  If not, see <http://www.gnu.org/licenses/>.
310
311A commercial license is available as well. Please contact roland@cpan.org for
312further details.
313
314=head1 PROFESSIONAL SERVICES
315
316Just in case you need professional support for this module (or Nagios or JMX in
317general), you might want to have a look at
318http://www.consol.com/opensource/nagios/. Contact roland.huss@consol.de for
319further information (or use the contact form at http://www.consol.com/contact/)
320
321=head1 AUTHOR
322
323roland@cpan.org
324
325=cut
326
3271;
328