File Coverage

blib/lib/Module/CPANTS/Analyse.pm

Criterion	Covered	Total	%
statement	128	165	77.5
branch	31	58	53.4
condition	9	18	50.0
subroutine	22	24	91.6
pod	9	9	100.0
total	199	274	72.6

package Module::CPANTS::Analyse;
use 5.008001;
use strict;
use warnings;
use base qw(Class::Accessor::Fast);
use File::Temp qw(tempdir);
use File::Spec::Functions qw(catfile catdir splitpath);
use File::Copy;
use File::stat;
use Archive::Any::Lite;
use Carp;
use Parse::Distname;

our $VERSION = '1.03';
$VERSION =~ s/_//; ## no critic

__PACKAGE__->mk_accessors(qw(dist opts tarball distdir d mck));
__PACKAGE__->mk_accessors(qw(_testdir _dont_cleanup _tarball _x_opts));

sub import {
    my $class = shift;
    require Module::CPANTS::Kwalitee;
    Module::CPANTS::Kwalitee->import(@_);
}

sub new {
    my $class = shift;
    my $opts = shift || {};
    $opts->{d} = {};
    $opts->{opts} ||= {};
    my $me = bless $opts, $class;
    Carp::croak("need a dist") if not defined $opts->{dist};

    $me->mck(Module::CPANTS::Kwalitee->new);

    # For Test::Kwalitee and friends
    $me->d->{is_local_distribution} = 1 if -d $opts->{dist};

    return $me;
}

sub run {
    my $me = shift;
    $me->unpack unless $me->d->{is_local_distribution};
    $me->analyse;
    $me->calc_kwalitee;
    $me->d;
}

sub unpack {
    my $me = shift;
    return 'cant find dist' unless $me->dist;

    my $di = Parse::Distname->new($me->dist);
    my $ext = $di->extension || 'unknown';

    $me->d->{package} = $di->filename;
    $me->d->{vname} = $di->distvname;
    $me->d->{extension} = $ext;
    $me->d->{version} = $di->version;
    $me->d->{dist} = $di->dist;
    $me->d->{author} = $di->cpanid;
    $me->d->{released} = stat($me->dist)->mtime;
    $me->d->{size_packed} = -s $me->dist;

    unless($me->d->{package}) {
        $me->d->{package} = $me->tarball;
    }

    copy($me->dist, $me->testfile);

    my @warnings;
    my @link_errors;
    my @pax_headers;
    eval {
        local $Archive::Zip::ErrorHandler = sub { die @_ };
        local $SIG{__WARN__} = sub {
            if ($_[0] =~ /^Making (?:hard|symbolic) link from '([^']+)'/) {
                push @link_errors, $1;
                return;
            }
            if ($_[0] =~ /^Invalid header/) {
                push @warnings, $_[0];
                return;
            }
            die @_;
        };

        local $Archive::Tar::CHMOD = 1;
        my $archive = Archive::Any::Lite->new($me->testfile);
        $archive->extract($me->testdir, {tar_filter_cb => sub {
            my $entry = shift;
            if ($entry->name eq Archive::Tar::Constant::PAX_HEADER() or $entry->type eq 'x' or $entry->type eq 'g') {
                push @pax_headers, $entry->name;
                return;
            }
            return 1;
        }});
    };
    if (my $error = $@) {
        $me->d->{extractable} = 0;
        $me->d->{error}{extractable} = $error;
        $me->d->{kwalitee}{extractable} = 0;
        my ($vol, $dir, $name) = splitpath($me->dist);
        $name =~ s/\..*$//;
        $name =~ s/\-[\d\.]+$//;
        $name =~ s/\-TRIAL[0-9]*//;
        $me->d->{dist} = $name;
        return $error;
    }

    if (@link_errors or @warnings) {
        # broken but some of the files may probably be extracted
        $me->d->{extractable} = 0;
        my %errors;
        $errors{link_errors}            = \@link_errors if @link_errors;
        $errors{warnings}               = \@warnings    if @warnings;
        $me->d->{error}{extractable}    = \%errors      if %errors;
        $me->d->{kwalitee}{extractable} = 0;
    } else {
        $me->d->{extractable} = 1;
    }

    if (@pax_headers) {
        $me->d->{no_pax_headers} = 0;
        $me->d->{error}{no_pax_headers} = join ',', @pax_headers;
    } else {
        $me->d->{no_pax_headers} = 1;
    }

    unlink($me->testfile);

    opendir(my $fh_testdir, $me->testdir) or die "Cannot open ".$me->testdir.": $!";
    my @stuff = grep {/\w/} readdir($fh_testdir);

    if (@stuff == 1) {
        $me->distdir(catdir($me->testdir, $stuff[0]));
        if (-d $me->distdir) {

          my $vname = $di->distvname;
          $vname =~ s/\-TRIAL[0-9]*//;

          $me->d->{extracts_nicely} = 1;
          if ($vname ne $stuff[0]) {
            $me->d->{error}{extracts_nicely} = "expected $vname but got $stuff[0]";
          }
        } else {
          $me->distdir($me->testdir);
          $me->d->{extracts_nicely} = 0;
          $me->d->{error}{extracts_nicely} = join ",", @stuff;
        }
    } else {
        $me->distdir($me->testdir);
        $me->d->{extracts_nicely} = 0;
        $me->d->{error}{extracts_nicely} = join ",", @stuff;
    }
    return;
}

sub analyse {
    my $me = shift;

    foreach my $mod (@{$me->mck->generators}) {
        $mod->analyse($me);
    }
}

sub calc_kwalitee {
    my $me = shift;

    my $kwalitee = 0;
    $me->d->{kwalitee} = {};
    my %x_ignore = %{$me->x_opts->{ignore} || {}};
    foreach my $i ($me->mck->get_indicators) {
        next if $i->{needs_db};
        my $rv = $i->{code}($me->d, $i);
        $me->d->{kwalitee}{$i->{name}} = $rv;
        if ($x_ignore{$i->{name}} && $i->{ignorable}) {
            $me->d->{kwalitee}{$i->{name}} = 1;
            if ($me->d->{error}{$i->{name}}) {
                $me->d->{error}{$i->{name}} .= ' [ignored]';
            }
        }
        $kwalitee += $rv;
    }

    $me->d->{'kwalitee'}{'kwalitee'} = $kwalitee;
}

#----------------------------------------------------------------
# helper methods
#----------------------------------------------------------------

sub testdir {
    my $me = shift;
    return $me->_testdir if $me->_testdir;
    if ($me->_dont_cleanup) {
        return $me->_testdir(tempdir());
    } else {
        return $me->_testdir(tempdir(CLEANUP => 1));
    }
}

sub testfile {
    my $me = shift;
    return catfile($me->testdir, $me->tarball);
}

sub tarball {
    my $me = shift;
    return $me->_tarball if $me->_tarball;
    my (undef, undef, $tb) = splitpath($me->dist);
    return $me->_tarball($tb);
}

sub x_opts {
    my $me = shift;
    return $me->_x_opts if $me->_x_opts;
    my %opts;
    if (my $x_cpants = $me->d->{meta_yml}{x_cpants}) {
        if (my $ignore = $x_cpants->{ignore}) {
            if (ref $ignore eq ref {}) {
                $opts{ignore} = $ignore;
            }
            else {
                $me->d->{error}{x_cpants} = "x_cpants ignore should be a hash reference (key: metric, value: reason to ignore)";
            }
        }
    }
    $me->_x_opts(\%opts);
}

q{Favourite record of the moment:
  Jahcoozi: Pure Breed Mongrel};

__END__