File Coverage

blib/lib/Test/Perl/Metrics/Lite.pm

Criterion	Covered	Total	%
statement	83	88	94.3
branch	17	26	65.3
condition	4	4	100.0
subroutine	18	18	100.0
pod	0	3	0.0
total	122	139	87.7

package Test::Perl::Metrics::Lite;
use strict;
our $VERSION = '0.2';

use List::MoreUtils qw(any);
use Perl::Metrics::Lite;
use Test::More ();
use Test::Builder;

my %METRICS_ARGS;

my $TEST = Test::Builder->new;

sub import {
    my ( $self, %args ) = @_;

    my $caller = caller;
    {
        no strict 'refs';    ## no critic qw(ProhibitNoStrict)
        *{ $caller . '::all_metrics_ok' } = \&all_metrics_ok;
    }

    $TEST->exported_to($caller);

    %METRICS_ARGS = %args;
    $METRICS_ARGS{-mccabe_complexity} ||= 10;
    $METRICS_ARGS{-loc}               ||= 60;

    return 1;
}

sub all_code_files {
    my @exceptions = @{ $METRICS_ARGS{-except_dir} || [] };
    my @dirs = @_;
    if ( not @dirs ) {
        @dirs = _starting_points();
    }
    @dirs = grep { !is_excluded( $_, @exceptions ) } @dirs;
    return \@dirs;
}

sub is_excluded {
    my ( $path, @exceptions ) = @_;
    any { $path eq $_ || $path =~ /$_/ } @exceptions;
}

sub _starting_points {
    return -e 'blib' ? 'blib' : 'lib';
}

sub all_metrics_ok {
    my @dirs = @_;

    Test::More::plan('no_plan');

    if ( not @dirs ) {
        @dirs = _starting_points();
    }
    my $files = all_code_files(@dirs);

    my $analysis = _analyze_metrics($files);
    my $ok       = _all_files_metric_ok( $analysis->sub_stats );
    return $ok;
}

sub _analyze_metrics {
    my $libs     = shift;
    my $analzyer = Perl::Metrics::Lite->new;
    my $analysis = $analzyer->analyze_files(@$libs);
    return $analysis;
}

sub _all_files_metric_ok {
    my $sub_stats = shift;
    my $ok        = 0;
    foreach my $file_path ( keys %{$sub_stats} ) {
        my @except_files = @{ $METRICS_ARGS{-except_file} || [] };
        next if is_excluded( $file_path, @except_files );

        my $sub_metrics = $sub_stats->{$file_path};
        $ok = $ok or _all_sub_metrics_ok($sub_metrics);
    }
    return $ok;
}

sub _all_sub_metrics_ok {
    my $sub_metrics = shift;
    my @rows        = ();
    my $ok          = 0;
    foreach my $sub_metric ( @{$sub_metrics} ) {
        $ok = $ok or _sub_metric_ok($sub_metric);
    }
    return $ok;
}

sub _sub_metric_ok {
    my $sub_metric = shift;

    my $ok = 0;
    $ok = $ok or _sub_loc_ok($sub_metric);
    $ok = $ok or _sub_cc_ok($sub_metric);
    return $ok;
}

sub _sub_cc_ok {
    my $sub_metric = shift;

    my $cc = $sub_metric->{mccabe_complexity};
    if ( $cc < $METRICS_ARGS{-mccabe_complexity} ) {
        $TEST->ok( 1, $sub_metric->{name} . " cc is ok" );
        return 0;
    }
    else {
        $TEST->ok( 0,
            "The method is to complex! Detail: Path: $sub_metric->{path}, Method: $sub_metric->{name}, CC: ${cc}"
        );
        return 1;
    }
}

sub _sub_loc_ok {
    my $sub_metric = shift;

    my $sloc = $sub_metric->{lines};
    if ( $sloc < $METRICS_ARGS{-loc} ) {
        $TEST->ok( 1, $sub_metric->{name} . " sloc is ok" );
        return 0;
    }
    else {
        $TEST->ok( 0,
            "The method is too long! Detail: Path: $sub_metric->{path} ,Method: $sub_metric->{name}, SLOC: ${sloc}"
        );
        return 1;
    }
}

1;
__END__