1#!/usr/bin/perl
2
3=head1 NAME
4
5JMX::Jmx4Perl::Request - A jmx4perl request
6
7=head1 SYNOPSIS
8
9  $req = JMX::Jmx4Perl::Request->new(READ,$mbean,$attribute);
10
11=head1 DESCRIPTION
12
13A L<JMX::Jmx4Perl::Request> encapsulates a request for various operational
14types.
15
16The following attributes are available:
17
18=over
19
20=item mbean
21
22Name of the targetted mbean in its canonical format.
23
24=item type
25
26Type of request, which should be one of the constants
27
28=over
29
30=item READ
31
32Get the value of a attribute
33
34=item WRITE
35
36Write an attribute
37
38=item EXEC
39
40Execute an JMX operation
41
42=item LIST
43
44List all MBeans available
45
46=item SEARCH
47
48Search for MBeans
49
50=item AGENT_VERSION
51
52Get the agent's version and extra runtime information of the serverside.
53
54=item REGISTER_NOTIFICATION
55
56Register for a JMX notification (not supported yet)
57
58=item REMOVE_NOTIFICATION
59
60Remove a JMX notification (not supported yet)
61
62=back
63
64=item attribute
65
66If type is C<READ> or C<WRITE> this specifies the requested
67attribute
68
69=item value
70
71For C<WRITE> this specifies the value to set
72
73=item arguments
74
75List of arguments of C<EXEC> operations
76
77=item path
78
79This optional parameter can be used to specify a nested value in an complex
80mbean attribute or nested return value from a JMX operation. For example, the
81MBean C<java.lang:type=Memory>'s attribute C<HeapMemoryUsage> is a complex
82value, which looks in the JSON representation like
83
84 "value":{"init":0,"max":518979584,"committed":41381888,"used":33442568}
85
86So, to fetch the C<"used"> value only, specify C<used> as path within the
87request. You can access deeper nested values by building up a path with "/" as
88separator. This looks a bit like a simplified form of XPath.
89
90=item maxDepth, maxObjects, maxCollectionSize, ignoreErrors
91
92With these number you can restrict the size of the JSON structure
93returned. C<maxDepth> gives the maximum nesting level of the JSON
94object,C<maxObjects> returns the maximum number of objects to be returned in
95total and C<maxCollectionSize> restrict the number of all arrays and
96collections (maps, lists) in the answer. Note, that you should use this
97restrictions if you are doing massive bulk operations. C<ignoreErrors> is
98useful for read requests with multiple attributes to skip errors while reading
99attribute values on the errors side (the error text will be set as value).
100
101=item target
102
103If given, the request is processed by the agent in proxy mode, i.e. it will
104proxy to another server exposing via a JSR-160 connector. C<target> is a hash
105which contains information how to reach the target service via the proxy. This
106hash knows the following keys:
107
108=over
109
110=item url
111
112JMX service URL as specified in JSR-160 pointing to the target server.
113
114=item env
115
116Further context information which is another hash.
117
118=back
119
120=back
121
122=head1 METHODS
123
124=over
125
126=cut
127
128package JMX::Jmx4Perl::Request;
129
130use strict;
131use vars qw(@EXPORT);
132use Carp;
133use Data::Dumper;
134
135use base qw(Exporter);
136@EXPORT = (
137           "READ","WRITE","EXEC","LIST", "SEARCH",
138           "REGNOTIF","REMNOTIF", "AGENT_VERSION"
139          );
140
141use constant READ => "read";
142use constant WRITE => "write";
143use constant EXEC => "exec";
144use constant LIST => "list";
145use constant SEARCH => "search";
146use constant REGNOTIF => "regnotif";
147use constant REMNOTIF => "remnotif";
148use constant AGENT_VERSION => "version";
149
150my $TYPES =
151{ map { $_ => 1 } (READ, WRITE, EXEC, LIST, SEARCH,
152                   REGNOTIF, REMNOTIF, AGENT_VERSION) };
153
154=item  $req = new JMX::Jmx4Perl::Request(....);
155
156 $req = new JMX::Jmx4Perl::Request(READ,$mbean,$attribute,$path, { ... options ... } );
157 $req = new JMX::Jmx4Perl::Request(READ,{ mbean => $mbean,... });
158 $req = new JMX::Jmx4Perl::Request({type => READ, mbean => $mbean, ... });
159
160The constructor can be used in various way. In the simplest form, you provide
161the type as first argument and depending on the type one or more additional
162attributes which specify the request. The second form uses the type as first
163parameter and a hashref containing named parameter for the request parameters
164(for the names, see above). Finally you can specify the arguments completely as
165a hashref, using 'type' for the entry specifying the request type.
166
167For the options C<maxDepth>, C<maxObjects> and C<maxCollectionSize>, you can mix
168them in into the hashref if using the hashed argument format. For the first
169format, these options are given as a final hashref.
170
171The option C<method> can be used to suggest a HTTP request method to use. By
172default, the agent decides automatically which HTTP method to use depending on
173the number of requests and whether an extended format should be used (which is
174only possible with an HTTP POST request). The value of this option can be
175either C<post> or C<get>, dependening on your preference.
176
177If the request should be proxied through this request, a target configuration
178needs to be given as optional parameter. The target configuration consists of a
179JMX service C<url> and a optional environment, which is given as a key-value
180map. For example
181
182 $req = new JMX::Jmx4Perl::Request(..., {
183                                     target => {
184                                                  url => "",
185                                                  env => { ..... }
186                                                }
187                                     } );
188
189Note, depending on the type, some parameters are mandatory. The mandatory
190parameters and the order of the arguments for the constructor variant without
191named parameters are:
192
193=over
194
195=item C<READ>
196
197 Order    : $mbean, $attribute, $path
198 Mandatory: $mbean, $attribute
199
200Note that C<$attribute> can be either a single name or a reference to a list
201of attribute names.
202
203=item C<WRITE>
204
205 Order    : $mbean, $attribute, $value, $path
206 Mandatory: $mbean, $attribute, $value
207
208=item C<EXEC>
209
210 Order    : $mbean, $operation, $arg1, $arg2, ...
211 Mandatory: $mbean, $operation
212
213
214=item C<LIST>
215
216 Order    : $path
217
218=item C<SEARCH>
219
220 Order    : $pattern
221 Mandatory: $pattern
222
223=back
224
225=cut
226
227sub new {
228    my $class = shift;
229    my $type = shift;
230    my $self;
231    # Hash as argument
232    if (ref($type) eq "HASH") {
233        $self = $type;
234        $type = $self->{type};
235    }
236    croak "Invalid type '",$type,"' given (should be one of ",join(" ",keys %$TYPES),")" unless $TYPES->{$type};
237
238    # Hash comes after type
239    if (!$self) {
240        if (ref($_[0]) eq "HASH") {
241            $self = $_[0];
242            $self->{type} = $type;
243        } else {
244            # Unnamed arguments
245            $self = {type =>  $type};
246
247            # Options are given as last part
248            my $opts = $_[scalar(@_)-1];
249            if (ref($opts) eq "HASH") {
250                pop @_;
251                map { $self->{$_} = $opts->{$_} } keys %$opts;
252                if ($self->{method}) {
253                    # Canonicalize and verify
254                    method($self,$self->{method});
255                }
256            }
257            if ($type eq READ) {
258                $self->{mbean} = shift;
259                $self->{attribute} = shift;
260                $self->{path} = shift;
261                # Use post for complex read requests
262                if (ref($self->{attribute}) eq "ARRAY") {
263                    my $method = method($self);
264                    if (defined($method) && $method eq "GET") {
265                        # Was already explicitely set
266                        die "Cannot query for multiple attributes " . join(",",@{$self->{attributes}}) . " with a GET request"
267                          if ref($self->{attribute}) eq "ARRAY";
268                    }
269                    method($self,"POST");
270                }
271            } elsif ($type eq WRITE) {
272                $self->{mbean} = shift;
273                $self->{attribute} = shift;
274                $self->{value} = shift;
275                $self->{path} = shift;
276            } elsif ($type eq EXEC) {
277                $self->{mbean} = shift;
278                $self->{operation} = shift;
279                $self->{arguments} = [ @_ ];
280            } elsif ($type eq LIST) {
281                $self->{path} = shift;
282            } elsif ($type eq SEARCH) {
283                $self->{mbean} = shift;
284                #No check here until now, is done on the server side as well.
285                #die "MBean name ",$self->{mbean}," is not a pattern" unless is_mbean_pattern($self);
286            } elsif ($type eq AGENT_VERSION) {
287                # No extra parameters required
288            }  else {
289                croak "Type ",$type," not supported yet";
290            }
291        }
292    }
293    bless $self,(ref($class) || $class);
294    $self->_validate();
295    return $self;
296}
297
298=item $req->method()
299
300=item $req->method("POST")
301
302Set the HTTP request method for this requst excplicitely. If not provided
303either during construction time (config key 'method') a prefered request
304method is determined dynamically based on the request contents.
305
306=cut 
307
308sub method {
309    my $self = shift;
310    my $value = shift;
311    if (defined($value)) {
312        die "Unknown request method ",$value if length($value) && uc($value) !~ /^(POST|GET)$/i;
313        $self->{method} = uc($value);
314    }
315    return defined($self->{method}) ? $self->{method} : undef;
316}
317
318=item $req->is_mbean_pattern
319
320Returns true, if the MBean name used in this request is a MBean pattern (which
321can be used in C<SEARCH> or for C<READ>) or not
322
323=cut
324
325sub is_mbean_pattern {
326    my $self = shift;
327    my $mbean = shift || $self->{mbean};
328    return 1 unless $mbean;
329    my ($domain,$rest) = split(/:/,$mbean,2);
330    return 1 if $domain =~ /[*?]/;
331    return 1 if $rest =~  /\*$/;
332
333    while ($rest) {
334        #print "R: $rest\n";
335        $rest =~ s/([^=]+)\s*=\s*//;
336        my $key = $1;
337        my $value;
338        if ($rest =~ /^"/) {
339            $rest =~ s/("(\\"|[^"])+")(\s*,\s*|$)//;
340            $value = $1;
341            # Pattern in quoted values must not be preceded by a \
342            return 1 if $value =~ /(?<!\\)[\*\?]/;
343        } else {
344            $rest =~ s/([^,]+)(\s*,\s*|$)//;
345            $value = $1;
346            return 1 if $value =~ /[\*\?]/;
347        }
348        #print "K: $key V: $value\n";
349    }
350    return 0;
351}
352
353=item $request->get("type")
354
355Get a request parameter
356
357=cut 
358
359sub get {
360    my $self = shift;
361    my $name = shift;
362    return $self->{$name};
363}
364
365# Internal check for validating that all arguments are given
366sub _validate {
367    my $self = shift;
368    if ($self->{type} eq READ ||  $self->{type} eq WRITE) {
369        die $self->{type} . ": No mbean name given\n",Dumper($self) unless $self->{mbean};
370        die $self->{type} . ": No attribute name but path is given\n" if (!$self->{attribute} && $self->{path});
371    }
372    if ($self->{type} eq WRITE) {
373        die $self->{type} . ": No value given\n" unless defined($self->{value});
374    }
375    if ($self->{type} eq EXEC) {
376        die $self->{type} . ": No mbean name given\n" unless $self->{mbean};
377        die $self->{type} . ": No operation name given\n" unless $self->{operation};
378    }
379}
380
381# Called for post requests
382sub TO_JSON {
383    my $self = shift;
384    my $ret = {
385               type => $self->{type} ? uc($self->{type}) : undef,
386              };
387    for my $k (qw(mbean attribute path value operation arguments target)) {
388        $ret->{$k} = $self->{$k} if defined($self->{$k});
389    }
390    my %config;
391    for my $k (qw(maxDepth maxObjects maxCollectionSize ignoreErrors)) {
392        $config{$k} = $self->{$k} if defined($self->{$k});
393    }
394    $ret->{config} = \%config if keys(%config);
395    return $ret;
396}
397
398=back
399
400=head1 LICENSE
401
402This file is part of jmx4perl.
403
404Jmx4perl is free software: you can redistribute it and/or modify
405it under the terms of the GNU General Public License as published by
406the Free Software Foundation, either version 2 of the License, or
407(at your option) any later version.
408
409jmx4perl is distributed in the hope that it will be useful,
410but WITHOUT ANY WARRANTY; without even the implied warranty of
411MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
412GNU General Public License for more details.
413
414You should have received a copy of the GNU General Public License
415along with jmx4perl.  If not, see <http://www.gnu.org/licenses/>.
416
417A commercial license is available as well. Please contact roland@cpan.org for
418further details.
419
420=head1 AUTHOR
421
422roland@cpan.org
423
424=cut
425
4261;
427