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

package Net::Tomcat;

use strict;
use warnings;

use LWP;
use Net::Tomcat::JVM;
use Net::Tomcat::Server;
use Net::Tomcat::Connector;
use Net::Tomcat::Connector::Scoreboard;
use Net::Tomcat::Connector::Statistics;

our $VERSION = '0.02';
our @ATTR = qw(username password hostname);
our $ATTR = {
	username		=>	{ required => 1					},
	password		=>	{ required => 1					},
	hostname		=>	{ required => 1					},
	port			=>	{ required => 0, default => 8080		},
	proto			=>	{ required => 0, default => 'http'		},
	app_status_url		=>	{ required => 0, default => '/manager/html/list'},
	server_status_url	=>	{ required => 0, default => '/manager/status/all'},
	refresh_interval	=>	{ required => 0, default => 3600		},
};

sub new {
	my ( $class, %args )  = @_;
	my $self        = bless {}, $class;

	for ( keys %{ $ATTR } ) {
		$ATTR->{$_}->{required} and ( defined $args{$_} or die "Mandatory parameter $_ not supplied in constructor\n" );
		$self->{$_} = ( $args{$_} or $ATTR->{$_}->{default} )
	}

	$self->{__ua}	= LWP::UserAgent->new();

	return $self
}

sub __request {
	my ( $self, $url ) = @_;

	my $res         = $self->{__ua}->get( "$self->{proto}://$self->{username}:$self->{password}"
						. "\@$self->{hostname}:$self->{port}$url" );

	$res->is_success and return $res->content;

	$self->{error}	= 'Unable to retrieve content: ' . $res->status_line;

	return 0
}

sub __is_valid {
	my ( $self, $o ) = @_;
	return ( defined $o and ( time - $o->{__timestamp} < $self->{refresh_interval} ) ? 1 : 0 )
}

sub server {
        my $self = shift;
        $self->__is_valid( $self->{__server} ) or $self->__get_server_status;
        return $self->{__server}
}

sub jvm {
	my $self = shift;
	$self->__is_valid( $self->{__jvm} ) or $self->__get_jvm_status;
	return $self->{__jvm}
}

sub connector {
        my ( $self, $connector ) = @_;

        for ( $self->connectors ) {
                return $_ if ( $_->name eq $connector )
        }

        warn "Connector '$connector' not defined\n";
}

sub connectors {
        my $self = shift;
        defined $self->{__connectors}
                and ( time - $self->{__connector_timestamp} < $self->{refresh_interval} )
                or $self->__get_server_status;

	return @{ $self->{__connectors} }
}

sub __get_server_status {
	my $self = shift;
	$self->__parse_server_status ( $self->__request( $self->{server_status_url} ) );
}

sub __get_jvm_status {
	my $self = shift;
	$self->__parse_server_status ( $self->__request( $self->{server_status_url} ) );
}

sub __get_app_list {
	my $self = shift;
	my $s = $self->__request( $self->{app_status_url} )
}

sub __parse_server_status {
        my ( $self, $s ) = @_;

        grep { /Server Status/ } $s or return ( $self->{error} = 'Unable to retrieve server status' );

        my @c = split /<\/table>/, $s;

        $self->__process_server_information(            grep { /Server Information/        } @c );
        $self->__process_jvm_information(               grep { /JVM<\/h1>/             } @c );
        $self->__process_connector_information(         grep { /JVM<\/h1>/             } split /\n/, $s );
}

sub __process_server_information {
        my ( $self, $s ) = @_;

        my @c = grep { /
        my ( @k, @v, %a );

        for ( @c ) {
                if ( /header-center/ )  { push @k, __strip_and_clean( $_ )      }
                if ( /row-center/    )  { push @v, __strip( $_ )                }
        }

        @a{ @k } = @v;
        $self->{__server} = Net::Tomcat::Server->new( %a );
}

sub __process_jvm_information {
        my ( $self, $s ) = @_;

        ( $s ) = grep { /JVM/ } ( split /<\/p>/, $s );
        $self->{__jvm} = Net::Tomcat::JVM->new( __extract_fields( $s ) );
}

sub __process_connector_information {
        my ( $self, $s ) = @_;
        my @c = grep { /<\/table>/ } split //, $s;

        for ( @c ) {
                next unless /<.*/;
                my ( $c_name, $c_stats ) = split /<\/h1>/;
                ( $c_stats, my $c_scoreboard ) = split /<\/p>/, $c_stats;
                $c_name         = __strip( $c_name );
                $c_stats        = Net::Tomcat::Connector::Statistics->new( __extract_fields( $c_stats ) );
                $c_scoreboard   = __process_scoreboard( $c_scoreboard );
                push @{ $self->{__connectors} },
                        Net::Tomcat::Connector->new(
                                name            => $c_name,
                                stats           => $c_stats,
                                scoreboard      => $c_scoreboard
                        );
                $self->{__connector_timestamp} = time;
        }
}

sub __process_scoreboard {
        my $s = shift;
        my @c = grep { !/<\/table>/ } split /<\/tr>/, $s;
        my @v = split /<\/th>/, ( shift @c );
        @v = [ map { __strip_and_clean( $_ ) } @v ];
        my ( %a );

        for ( @c ) {
                my @f = split /<\/td>/;
                @f = map { __strip( $_ ) } @f;
                push @v, [ @f ]
        }

        return Net::Tomcat::Connector::Scoreboard->new( @v )
}

sub __extract_fields {
        my $s = shift;
        $s =~ s/([A-Z]{1}[a-z]{1})/_$1/g;
        my @c = ( split /_/, $s );
        my ( @k, @v, %a );

        for ( @c ) {
                my ( $k, $v ) = split /:/;
                next unless $k and $v;
                push @k, __strip_and_clean( $k );
                push @v, __strip( $v );
        }

        @a{ @k } = @v;
        return %a
}

sub __strip {
        my $s = shift;
        $s =~ s|<.+?>||g;
        $s =~ s/^\s+|\s+$//g;
        return $s
}

sub __strip_and_clean {
        my $s = shift;
        $s = __strip( $s );
        $s =~ s| |_|g;
        $s = lc( $s );
        return $s
}

1;

__END__