package Module::CPANTS::Analyse;
use strict;
use warnings;
use base qw(Class::Accessor);
use File::Temp qw(tempdir);
use File::Spec::Functions qw(catfile catdir splitpath);
use File::Copy;
use Archive::Any;
use Carp;
use Module::CPANTS::Kwalitee;
use IO::Capture::Stdout;
use IO::Capture::Stderr;
use YAML qw(LoadFile);
use vars qw($VERSION);
$VERSION=0.69;
use Module::Pluggable search_path=>['Module::CPANTS::Kwalitee'];
__PACKAGE__->mk_accessors(qw(dist tarball distdir d mck capture_stdout capture_stderr));
__PACKAGE__->mk_accessors(qw(_testdir _dont_cleanup _tarball));
sub new {
my $class=shift;
my $opts=shift || {};
$opts->{d}={};
my $me=bless $opts,$class;
$me->mck(Module::CPANTS::Kwalitee->new);
my $cserr=IO::Capture::Stderr->new;
my $csout=IO::Capture::Stdout->new;
$cserr->start;
$csout->start;
$me->capture_stderr($cserr);
$me->capture_stdout($csout);
return $me;
}
sub unpack {
my $me=shift;
return 'cant find dist' unless $me->dist;
copy($me->dist,$me->testfile);
chdir($me->testdir);
$me->d->{size_packed}=-s $me->testfile;
my $archive;
eval {
$archive=Archive::Any->new($me->testfile);
$archive->extract();
};
if (my $error=$@) {
$me->capture_stdout->stop;
$me->capture_stderr->stop;
$me->d->{extractable}=0;
$me->d->{cpants_errors}=$error;
$me->d->{kwalitee}{extractable}=0;
return $error;
}
$me->d->{extractable}=1;
unlink($me->testfile);
opendir(my $fh_testdir,$me->testdir) || die "Cannot open ".$me->testdir.": $!";
my @stuff=grep {/\w/} readdir($fh_testdir);
my $di=CPAN::DistnameInfo->new($me->dist);
if (@stuff == 1) {
$me->distdir(catdir($me->testdir,$stuff[0]));
$me->d->{extracts_nicely}=1 if $di->distvname eq $stuff[0];
} else {
$me->distdir(catdir($me->testdir));
$me->d->{extracts_nicely}=0;
}
return;
}
sub analyse {
my $me=shift;
foreach my $mod (@{$me->mck->generators}) {
$mod->analyse($me);
}
}
sub calc_kwalitee {
my $me=shift;
my $kwalitee=0;
my %k;
foreach my $mod (@{$me->mck->generators}) {
foreach my $i (@{$mod->kwalitee_indicators}) {
my $rv=$i->{code}($me->d);
$k{$i->{name}}=$rv;
$kwalitee+=$rv;
}
}
$k{'kwalitee'}=$kwalitee;
$me->d->{kwalitee}=\%k;
}
#----------------------------------------------------------------
# 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);
}
q{Favourite record of the moment:
Jahcoozi: Pure Breed Mongrel};
__END__
=pod
=head1 NAME
Module::CPANTS::Analyse - Generate Kwalitee ratings for a distribution
=head1 SYNOPSIS
my $analyser=Module::CPANTS::Analyse(
{
dist=>'path/to/Foo-Bar-1.42.tgz',
}
);
$a->unpack;
$a->analyse;
$a->calc_kwalitee;
# results are in $a->d;
=head1 DESCRIPTION
=head2 Methods
=head3 new
my $analyser=Module::CPANTS::Analyse->new({dist=>'path/to/file'});
Plain old constructor.
=head3 unpack
Unpack the distribution into a temporary directory.
Returns an error if something went wrong, C<undef> if all went well.
=head3 analyse
Run all analysers (defined in C<Module::CPANTS::Kwalitee::*> on the dist.
=head3 calc_kwalitee
Check if the dist conforms to the Kwalitee indicators.
=head2 Helper Methods
=head3 testdir
Returns the path to the unique temp directory.
=head3 testfile
Returns the location of the unextracted tarball.
=head3 tarball
Returns the filename of the tarball.
=head3 read_meta_yml
Reads the META.yml file and returns its content.
=head1 WEBSITE
http://cpants.perl.org/
=head1 BUGS
Please report any bugs or feature requests, or send any patches, to
bug-module-cpants-analyse at rt.cpan.org, or through the web interface at
http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Module-CPANTS-Analyse.
I will be notified, and then you'll automatically be notified of progress
on your bug as I make changes.
=head1 AUTHOR
Thomas Klausner, <domm@cpan.org>, http://domm.zsi.at
Please use the perl-qa mailing list for discussing all things CPANTS:
http://lists.perl.org/showlist.cgi?name=perl-qa
Based on work by Leon Brocard <acme@astray.com> and the original idea
proposed by Michael G. Schwern <schwern@pobox.com>
=head1 LICENSE
This code is Copyright (c) 2003-2006 Thomas Klausner.
All rights reserved.
You may use and distribute this module according to the same terms
that Perl is distributed under.
=cut
syntax highlighted by Code2HTML, v. 0.9.1