File Coverage

blib/lib/Net/Tomcat.pm
Criterion Covered Total %
statement 24 130 18.4
branch 0 22 0.0
condition 0 14 0.0
subroutine 8 26 30.7
pod 5 5 100.0
total 37 197 18.7


line stmt bran cond sub pod time code
1             package Net::Tomcat;
2              
3 1     1   23388 use strict;
  1         2  
  1         43  
4 1     1   6 use warnings;
  1         2  
  1         34  
5              
6 1     1   8479 use LWP;
  1         185074  
  1         46  
7 1     1   666 use Net::Tomcat::JVM;
  1         2  
  1         33  
8 1     1   413 use Net::Tomcat::Server;
  1         2  
  1         31  
9 1     1   455 use Net::Tomcat::Connector;
  1         2  
  1         31  
10 1     1   429 use Net::Tomcat::Connector::Scoreboard;
  1         2  
  1         31  
11 1     1   879 use Net::Tomcat::Connector::Statistics;
  1         2  
  1         1702  
12              
13             our $VERSION = '0.01';
14             our @ATTR = qw(username password hostname);
15             our $ATTR = {
16             username => { required => 1 },
17             password => { required => 1 },
18             hostname => { required => 1 },
19             port => { required => 0, default => 8080 },
20             proto => { required => 0, default => 'http' },
21             app_status_url => { required => 0, default => '/manager/html/list'},
22             server_status_url => { required => 0, default => '/manager/status/all'},
23             refresh_interval => { required => 0, default => 3600 },
24             };
25              
26             sub new {
27 0     0 1   my ( $class, %args ) = @_;
28 0           my $self = bless {}, $class;
29              
30 0           for ( keys %{ $ATTR } ) {
  0            
31 0 0 0       $ATTR->{$_}->{required} and ( defined $args{$_} or die "Mandatory parameter $_ not supplied in constructor\n" );
32 0   0       $self->{$_} = ( $args{$_} or $ATTR->{$_}->{default} )
33             }
34              
35 0           $self->{__ua} = LWP::UserAgent->new();
36              
37 0           return $self
38             }
39              
40             sub __request {
41 0     0     my ( $self, $url ) = @_;
42              
43 0           my $res = $self->{__ua}->get( "$self->{proto}://$self->{username}:$self->{password}"
44             . "\@$self->{hostname}:$self->{port}$url" );
45              
46 0 0         $res->is_success and return $res->content;
47              
48 0           $self->{error} = 'Unable to retrieve content: ' . $res->status_line;
49              
50 0           return 0
51             }
52              
53             sub __is_valid {
54 0     0     my ( $self, $o ) = @_;
55 0   0       return ( defined $o and ( time - $o->{__timestamp} < $self->{refresh_interval} ) ? 1 : 0 )
56             }
57              
58             sub server {
59 0     0 1   my $self = shift;
60 0 0         $self->__is_valid( $self->{__server} ) or $self->__get_server_status;
61 0           return $self->{__server}
62             }
63              
64             sub jvm {
65 0     0 1   my $self = shift;
66 0 0         $self->__is_valid( $self->{__jvm} ) or $self->__get_jvm_status;
67 0           return $self->{__jvm}
68             }
69              
70             sub connector {
71 0     0 1   my ( $self, $connector ) = @_;
72              
73 0           for ( $self->connectors ) {
74 0 0         return $_ if ( $_->name eq $connector )
75             }
76              
77 0           warn "Connector '$connector' not defined\n";
78             }
79              
80             sub connectors {
81 0     0 1   my $self = shift;
82 0 0 0       defined $self->{__connectors}
83             and ( time - $self->{__connector_timestamp} < $self->{refresh_interval} )
84             or $self->__get_server_status;
85              
86 0           return @{ $self->{__connectors} }
  0            
87             }
88              
89             sub __get_server_status {
90 0     0     my $self = shift;
91 0           $self->__parse_server_status ( $self->__request( $self->{server_status_url} ) );
92             }
93              
94             sub __get_jvm_status {
95 0     0     my $self = shift;
96 0           $self->__parse_server_status ( $self->__request( $self->{server_status_url} ) );
97             }
98              
99             sub __get_app_list {
100 0     0     my $self = shift;
101 0           my $s = $self->__request( $self->{app_status_url} )
102             }
103              
104             sub __parse_server_status {
105 0     0     my ( $self, $s ) = @_;
106            
107 0 0         grep { /Server Status/ } $s or return ( $self->{error} = 'Unable to retrieve server status' );
  0            
108              
109 0           my @c = split /<\/table>/, $s;
110              
111 0           $self->__process_server_information( grep { /Server Information/ } @c );
  0            
112 0           $self->__process_jvm_information( grep { /

JVM<\/h1>/ } @c );

  0            
113 0           $self->__process_connector_information( grep { /

JVM<\/h1>/ } split /\n/, $s );

  0            
114             }
115              
116             sub __process_server_information {
117 0     0     my ( $self, $s ) = @_;
118              
119 0           my @c = grep { /
  0            
120 0           my ( @k, @v, %a );
121            
122 0           for ( @c ) {
123 0 0         if ( /header-center/ ) { push @k, __strip_and_clean( $_ ) }
  0            
124 0 0         if ( /row-center/ ) { push @v, __strip( $_ ) }
  0            
125             }
126              
127 0           @a{ @k } = @v;
128 0           $self->{__server} = Net::Tomcat::Server->new( %a );
129             }
130              
131             sub __process_jvm_information {
132 0     0     my ( $self, $s ) = @_;
133              
134 0           ( $s ) = grep { /JVM/ } ( split /<\/p>/, $s );
  0            
135 0           $self->{__jvm} = Net::Tomcat::JVM->new( __extract_fields( $s ) );
136             }
137              
138             sub __process_connector_information {
139 0     0     my ( $self, $s ) = @_;
140 0           my @c = grep { /<\/table>/ } split /

/, $s;

  0            
141              
142 0           for ( @c ) {
143 0 0         next unless /<.*/;
144 0           my ( $c_name, $c_stats ) = split /<\/h1>/;
145 0           ( $c_stats, my $c_scoreboard ) = split /<\/p>/, $c_stats;
146 0           $c_name = __strip( $c_name );
147 0           $c_stats = Net::Tomcat::Connector::Statistics->new( __extract_fields( $c_stats ) );
148 0           $c_scoreboard = __process_scoreboard( $c_scoreboard );
149 0           push @{ $self->{__connectors} },
  0            
150             Net::Tomcat::Connector->new(
151             name => $c_name,
152             stats => $c_stats,
153             scoreboard => $c_scoreboard
154             );
155 0           $self->{__connector_timestamp} = time;
156             }
157             }
158              
159             sub __process_scoreboard {
160 0     0     my $s = shift;
161 0           my @c = grep { !/<\/table>/ } split /<\/tr>/, $s;
  0            
162 0           my @v = split /<\/th>/, ( shift @c );
163 0           @v = [ map { __strip_and_clean( $_ ) } @v ];
  0            
164 0           my ( %a );
165            
166 0           for ( @c ) {
167 0           my @f = split /<\/td>/;
168 0           @f = map { __strip( $_ ) } @f;
  0            
169 0           push @v, [ @f ]
170             }
171              
172 0           return Net::Tomcat::Connector::Scoreboard->new( @v )
173             }
174              
175             sub __extract_fields {
176 0     0     my $s = shift;
177 0           $s =~ s/([A-Z]{1}[a-z]{1})/_$1/g;
178 0           my @c = ( split /_/, $s );
179 0           my ( @k, @v, %a );
180              
181 0           for ( @c ) {
182 0           my ( $k, $v ) = split /:/;
183 0 0 0       next unless $k and $v;
184 0           push @k, __strip_and_clean( $k );
185 0           push @v, __strip( $v );
186             }
187            
188 0           @a{ @k } = @v;
189 0           return %a
190             }
191              
192             sub __strip {
193 0     0     my $s = shift;
194 0           $s =~ s|<.+?>||g;
195 0           $s =~ s/^\s+|\s+$//g;
196 0           return $s
197             }
198              
199             sub __strip_and_clean {
200 0     0     my $s = shift;
201 0           $s = __strip( $s );
202 0           $s =~ s| |_|g;
203 0           $s = lc( $s );
204 0           return $s
205             }
206              
207             1;
208              
209             __END__