File Coverage

blib/lib/App/plmetrics.pm

Criterion	Covered	Total	%
statement	124	159	77.9
branch	25	40	62.5
condition	4	4	100.0
subroutine	24	27	88.8
pod	3	3	100.0
total	180	233	77.2

package App::plmetrics;
use strict;
use warnings;
use Module::Path;
use Perl::Metrics::Lite;
use Statistics::Swoop;
use Text::ASCIITable;

our $VERSION = '0.06';

my %VIEWER = (
    qr/^modules?$/i => sub { $_[0]->_view_module($_[1]) },
    qr/^methods?$/i => sub { $_[0]->_view_methods($_[1]) },
    qr/^cc$/i       => sub { $_[0]->_view_cc_lines($_[1], 'cc') },
    qr/^lines?$/i   => sub { $_[0]->_view_cc_lines($_[1], 'lines') },
    qr/^files?$/i   => sub { $_[0]->_view_files($_[1]) },
);

sub new {
    my ($class, $opt) = @_;
    bless +{ opt => $opt } => $class;
}

sub opt { $_[0]->{opt} }

sub run {
    my $self = shift;

    my ($targets, $base_path) = $self->_get_targets;
    my $stats = $self->_get_stats($targets, $base_path);
    $self->_view($stats);
}

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

    my $result_opt = $self->opt->{'--result'} || 'module';

    for my $regex (keys %VIEWER) {
        if ($result_opt =~ $regex) {
            $VIEWER{$regex}->($self, $stats);
            return;
        }
    }
    print STDERR "wrong option: --result $result_opt\nsee the --help\n";
}

sub _view_cc_lines {
    my ($self, $stats, $label) = @_;

    print "$label\n";
    my $t = Text::ASCIITable->new;
    my @metrics_keys = keys %{$stats};
    for my $pl ( $self->opt->{'--sort'} ? sort @metrics_keys : @metrics_keys ) {
        $t->setCols($self->_header);
        $t->addRow( $pl, $self->_row($stats->{$pl}{$label}) );
    }
    print $t. "\n";
}

sub _header { ('', qw/avg max min range sum methods/) }

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

    my $stats = Statistics::Swoop->new($list);
    return( $self->_round($stats->avg), $stats->max, $stats->min,
                $stats->range, $stats->sum, $stats->count );
}

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

    my @metrics_keys = keys %{$stats};
    for my $pl ( $self->opt->{'--sort'} ? sort @metrics_keys : @metrics_keys ) {
        print "$pl\n";
        my $t = Text::ASCIITable->new;
        $t->setCols($self->_header);
        $t->addRow( 'cc', $self->_row($stats->{$pl}{cc}) );
        $t->addRow( 'lines', $self->_row($stats->{$pl}{lines}) );
        print $t. "\n";
    }
}

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

    print "files\n";
    my $t = Text::ASCIITable->new;
    $t->setCols(qw/file lines methods packages/);
    my @metrics_keys = keys %{$stats};
    for my $pl ( $self->opt->{'--sort'} ? sort @metrics_keys : @metrics_keys ) {
        $t->addRow(
            $pl,
            $stats->{$pl}{file_stats}{lines},
            $stats->{$pl}{file_stats}{methods},
            $stats->{$pl}{file_stats}{packages},
        );
    }
    print $t. "\n";
}

sub _round { sprintf("%.2f", $_[1]) }

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

    my @metrics_keys = keys %{$stats};
    for my $pl ( $self->opt->{'--sort'} ? sort @metrics_keys : @metrics_keys ) {
        print "$pl\n";
        my $t = Text::ASCIITable->new;
        $t->setCols('', 'cc', 'lines');
        my $ref = $stats->{$pl}{method};
        my @methods_keys = keys %{$ref};
        for my $method ( $self->opt->{'--sort'} ? sort @methods_keys : @methods_keys ) {
            $t->addRow($method, $ref->{$method}{cc}, $ref->{$method}{lines});
        }
        print $t. "\n";
    }
}

sub _get_stats {
    my ($self, $targets, $base_path) = @_;

    my $m = Perl::Metrics::Lite->new;
    my $analysis = $m->analyze_files(@{$targets});

    my $stats = ( ($self->opt->{'--result'} || '') =~ m!^files?$!i )
              ? $self->_get_file_stats($analysis, $base_path)
              : $self->_get_sub_stats($analysis, $base_path);
    return $stats;
}

sub _get_sub_stats {
    my ($self, $analysis, $base_path) = @_;

    my %stats;
    for my $full_path (keys %{($analysis->sub_stats)}) {
        for my $sub (@{$analysis->sub_stats->{$full_path}}) {
            $sub->{path} =~ s!$base_path/!! if $base_path;
            my $cc    = $sub->{mccabe_complexity};
            my $lines = $sub->{lines};
            $stats{$sub->{path}}->{method}{$sub->{name}} = +{
                cc    => $cc,
                lines => $lines,
            };
            push @{ $stats{$sub->{path}}->{cc} }, $cc;
            push @{ $stats{$sub->{path}}->{lines} }, $lines;
        }
    }
    return \%stats;
}

sub _get_file_stats {
    my ($self, $analysis, $base_path) = @_;

    my %stats;
    for my $f (@{$analysis->file_stats}) {
        $f->{path} =~ s!$base_path/!! if $base_path;
        $stats{$f->{path}}->{file_stats} = +{
            packages => $f->{main_stats}{packages},
            lines    => $f->{main_stats}{lines},
            methods  => $f->{main_stats}{number_of_methods},
        };
    }
    return \%stats;
}

sub _get_targets {
    my $self = shift;

    return   $self->opt->{'--dir'}    ? $self->_target_dir
           : $self->opt->{'--tar'}    ? $self->_target_tar
           : $self->opt->{'--git'}    ? $self->_target_git
           : $self->opt->{'--file'}   ? $self->_target_file
           : $self->opt->{'--module'} ? $self->_target_module : [];
}

sub _target_module {
    my $self = shift;

    my $path = Module::Path::module_path($self->opt->{'--module'});
    my @targets;
    if ($path) {
        push @targets, $path;
    }
    else {
        print STDERR "No such module: ". $self->opt->{'--module'}. "\n";
    }
    return(\@targets, '');
}

sub _target_file {
    my $self = shift;

    my @targets;
    push @targets, $self->opt->{'--file'} if -f $self->opt->{'--file'};

    return(\@targets, '');
}

sub _target_dir {
    my $self = shift;

    my @targets;
    my $dir = $self->opt->{'--dir'};
    push @targets, $dir if -d $dir;

    return(\@targets, $dir);
}

sub _target_git {
    my $self = shift;

    $self->_load_or_recommend(qw/
        File::Temp
        Path::Class
        Git::Repository
    /);

    my $work_dir = File::Temp::tempdir(CLEANUP => 1);
    my $repo_dir = Path::Class::dir($work_dir);

    Git::Repository->run(
        clone => $self->opt->{'--git'},
        $repo_dir->stringify,
    );

    my @targets;
    for my $dir (qw/lib script bin/) {
        my $dir_path = "$repo_dir/$dir";
        push @targets, $dir_path if -d $dir_path;
    }

    return(\@targets, $repo_dir);
}

sub _target_tar {
    my $self = shift;

    $self->_load_or_recommend(qw/
        File::Temp
        LWP::Simple
        Archive::Tar
    /);

    my $work_dir = File::Temp::tempdir(CLEANUP => 1);
    my ($fh, $filename) = File::Temp::tempfile(
        DIR    => $work_dir,
        SUFFIX => '.tar.gz',
    );

    my $tar_url = $self->opt->{'--tar'};
    my ($module_dir) = ($tar_url =~ m!/([^/]+)\.tar\.gz!);

    LWP::Simple::getstore($tar_url => $filename);

    my $tar = Archive::Tar->new;
    $tar->read($filename);
    $tar->setcwd($work_dir);
    $tar->extract;

    my @targets;
    for my $dir (qw/lib script bin/) {
        my $dir_path = "$work_dir/$module_dir/$dir";
        push @targets, $dir_path if -d $dir_path;
    }

    return(\@targets, "$work_dir/$module_dir");
}

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

    for my $module (@modules) {
        eval {
            my $file = $module;
            $file =~ s!::!/!g;
            require "$file.pm"; ## no critic
        };
        if (my $e = $@) {
            die <<"_MESSAGE_";
ERROR: This system does NOT have [$module] for executing this task.
Would you mind installing $module?

\$ cpanm $module

_MESSAGE_
        }
        else {
            $module->import;
        }
    }
}

1;

__END__