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 if all went well. =head3 analyse Run all analysers (defined in C 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, , 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 and the original idea proposed by Michael G. Schwern =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