File Coverage

blib/lib/Plack/Middleware/ModuleInfo.pm

Criterion	Covered	Total	%
statement	58	65	89.2
branch	20	28	71.4
condition	3	6	50.0
subroutine	11	11	100.0
pod	2	2	100.0
total	94	112	83.9

package Plack::Middleware::ModuleInfo;
use strict;
use warnings;
use parent qw/Plack::Middleware/;
use Plack::Util::Accessor qw/ path allow dumper /;
use Net::CIDR::Lite;
use Module::Info;

our $VERSION = '0.02';

sub prepare_app {
    my $self = shift;

    # this code of block was copied from Plack::Middleware::ServerStatus::Lite ;-P
    if ( $self->allow ) {
        my @ip = ref $self->allow ? @{$self->allow} : ($self->allow);
        my @ipv4;
        my @ipv6;
        for (@ip) {
            # hacky check, but actual checks are done in Net::CIDR::Lite.
            if (/:/) {
                push @ipv6, $_;
            } else {
                push @ipv4, $_;
            }
        }
        if ( @ipv4 ) {
            my $cidr4 = Net::CIDR::Lite->new();
            $cidr4->add_any($_) for @ipv4;
            $self->{__cidr4} = $cidr4;
        }
        if ( @ipv6 ) {
            my $cidr6 = Net::CIDR::Lite->new();
            $cidr6->add_any($_) for @ipv6;
            $self->{__cidr6} = $cidr6;
        }
    }

    if (!$self->allow || !$self->path) {
        warn "[Plack::Middleware::ModuleInfo] 'allow' is not provided."
                . "Any host will not be able to access the information.\n";
    }

    unless ($self->dumper) {
        require YAML;
        $self->dumper(sub{
            my ($info, $env) = @_;
            return [
                200,
                ['Content-Type' => 'text/plain'],
                [YAML::Dump($info)]
            ];
        });
    }
}

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

    my $path = $self->path;

    if( $path && $env->{PATH_INFO} =~ m!^$path! ) {
        my $res = $self->_handle_module_info($env);
        return $res;
    }

    my $res = $self->app->($env);

    return $res;
}

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

    if ( ! $self->_allowed($env->{REMOTE_ADDR}) ) {
        return [403, ['Content-Type' => 'text/plain'], [ 'Forbidden' ]];
    }

    my $info = { PID => $$, lib => \@INC, };

    if ( my $input_module = $env->{QUERY_STRING} ) {
        $input_module =~ s/-/::/g;
        if ( my $mod = Module::Info->new_from_loaded($input_module) ) {
            $info->{module} = {
                name    => $mod->name,
                version => $mod->version,
                file    => $mod->file,
            };
        }
        else {
            $info->{module} = "'$input_module' not found";
        }
    }

    return $self->dumper->($info, $env);
}

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

    if ( $address =~ /:/) {
        return unless $self->{__cidr6};
        return $self->{__cidr6}->find( $address );
    }
    return unless $self->{__cidr4};
    return $self->{__cidr4}->find( $address );
}

1;

__END__