File Coverage

blib/lib/JMX/Jmx4Perl/Agent/UserAgent.pm
Criterion Covered Total %
statement 25 72 34.7
branch 2 22 9.0
condition 1 8 12.5
subroutine 8 15 53.3
pod 3 8 37.5
total 39 125 31.2


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             # Helper package in order to provide credentials
4             # in the request
5             package JMX::Jmx4Perl::Agent::UserAgent;
6 3     3   22 use base qw(LWP::UserAgent);
  3         6  
  3         2202  
7              
8 3     3   82818 use Sys::SigAction;
  3         21727  
  3         157  
9              
10 3     3   25 use vars qw($HAS_BLOWFISH_PP $BF);
  3         7  
  3         154  
11 3     3   18 use strict;
  3         10  
  3         263  
12              
13             BEGIN {
14 3     3   229 $HAS_BLOWFISH_PP = eval "require Crypt::Blowfish_PP; 1";
15 3 50       23 if ($HAS_BLOWFISH_PP) {
16 3         22 $BF = new Crypt::Blowfish_PP(pack("C10",0x16,0x51,0xAE,0x13,0xF2,0xFA,0x11,0x20,0x6E,0x6A));
17             }
18             }
19              
20              
21             =head1 NAME
22              
23             JMX::Jmx4Perl::Agent::UserAgent - Specialized L adding
24             authentication support
25              
26             =head1 DESCRIPTION
27              
28             Simple subclass implementing an own C method for support
29             of basic and proxy authentication. This is an internal class used by
30             L.
31              
32             =cut
33              
34              
35             # Constructor setting the proper SSL options (if possible)
36             sub new {
37 5     5 1 12 my $class = shift;
38 5   33     27 my @opts = @_ || ();
39 5 50       99 if (LWP::UserAgent->VERSION >= 6.00) {
40             # We don't verify Hostnames by default, since the information we are
41             # sending is typically not critical. Also, we don't have yet a way to
42             # configure a keystore, so this is the only chance for now. Ask me to add
43             # host certificate verification if wanted. It disabled only for LWP >= 6.00
44 5         20 push @opts,(ssl_opts => { verify_hostname => 0 });
45             };
46 5         53 return $class->SUPER::new(@opts);
47             }
48              
49             # Request using a more robust timeout See
50             # http://stackoverflow.com/questions/73308/true-timeout-on-lwpuseragent-request-method
51             # for details.
52             sub request {
53 0     0 1 0 my $self = shift;
54 0         0 my $req = shift;
55              
56             # Get whatever timeout is set for LWP and use that to
57             # enforce a maximum timeout per request.
58 3     3   473600 use Sys::SigAction qw(timeout_call);
  3         10  
  3         2575  
59 0         0 our $res = undef;
60 0 0   0   0 if (timeout_call($self->timeout(), sub { $res = $self->SUPER::request($req); })) {
  0         0  
61             # 408 == HTTP timeout
62 0         0 my $ret = HTTP::Response->new(408,"Got timeout in " . $self->timeout() . "s ");
63 0         0 $ret->request($req);
64 0         0 return $ret;
65             } else {
66 0         0 return $res;
67             }
68              
69             }
70              
71             sub jjagent_config {
72 5     5 0 11 my $self = shift;
73 5         21 $self->{jjagent_config} = shift;
74             }
75              
76             sub get_basic_credentials {
77 0     0 1   my ($self, $realm, $uri, $isproxy) = @_;
78              
79 0   0       my $cfg = $self->{jjagent_config} || {};
80 0 0         my $user = $isproxy ? $self->proxy_cfg($cfg,"user") : $cfg->{user};
81 0 0         my $password = $isproxy ? $self->proxy_cfg($cfg,"password") : $cfg->{password};
82 0 0 0       if ($user && $password) {
83 0           return ($user,$self->conditionally_decrypt($password));
84             } else {
85 0           return (undef,undef);
86             }
87             }
88              
89             sub proxy_cfg {
90 0     0 0   my ($self,$cfg,$what) = @_;
91 0           my $proxy = $cfg->{proxy};
92 0 0         if (ref($proxy) eq "HASH") {
93 0           return $proxy->{$what};
94             } else {
95 0           return $cfg->{"proxy_" . $what};
96             }
97             }
98              
99             sub conditionally_decrypt {
100 0     0 0   my $self = shift;
101 0           my $password = shift;
102 0 0         if ($password =~ /^\[\[\s*(.*)\s*\]\]$/) {
103             # It's a encrypted password, lets decrypt it here
104 0           return decrypt($1);
105             } else {
106 0           return $password;
107             }
108             }
109              
110             sub decrypt {
111 0     0 0   my $encrypted = shift;
112 0 0         die "No encryption available. Please install Crypt::Blowfish_PP" unless $HAS_BLOWFISH_PP;
113 0           my $rest = $encrypted;
114 0           my $ret = "";
115 0           while (length($rest) > 0) {
116 0           my $block = substr($rest,0,16);
117 0           $rest = substr($rest,16);
118 0           $ret .= $BF->decrypt(pack("H*",$block));
119             }
120 0           $ret =~ s/\s*$//;
121 0           return $ret;
122             }
123              
124             sub encrypt {
125 0     0 0   my $plain = shift;
126 0 0         die "No encryption available. Please install Crypt::Blowfish_PP" unless $HAS_BLOWFISH_PP;
127 0           my $rest = $plain;
128 0           my $ret = "";
129 0           while (length($rest) > 0) {
130 0           my $block = substr($rest,0,8);
131 0 0         if (length($block) < 8) {
132 0           $block .= " " x (8 - length($block));
133             }
134 0           $rest = substr($rest,8);
135 0           $ret .= unpack("H*",$BF->encrypt($block));
136             }
137 0           return $ret;
138             }
139              
140             =head1 LICENSE
141              
142             This file is part of jmx4perl.
143             Jmx4perl is free software: you can redistribute it and/or modify
144             it under the terms of the GNU General Public License as published by
145             The Free Software Foundation, either version 2 of the License, or
146             (at your option) any later version.
147            
148             jmx4perl is distributed in the hope that it will be useful,
149             but WITHOUT ANY WARRANTY; without even the implied warranty of
150             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
151             GNU General Public License for more details.
152            
153             You should have received a copy of the GNU General Public License
154             along with jmx4perl. If not, see .
155              
156             A commercial license is available as well. Please contact roland@cpan.org for
157             further details.
158              
159             =head1 AUTHOR
160              
161             roland@cpan.org
162              
163             =cut
164              
165             1;
166              
167             __DATA__