File Coverage

blib/lib/CPAN/Mini/Tested.pm

Criterion	Covered	Total	%
statement	92	116	79.3
branch	26	50	52.0
condition	9	35	25.7
subroutine	20	23	86.9
pod	3	3	100.0
total	150	227	66.0

package CPAN::Mini::Tested;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.23';

#--------------------------------------------------------------------------

###########################################################################
# Inheritence

use base 'CPAN::Mini';

###########################################################################
# Modules

use Cache::Simple::TimedExpiry  0.22;
use Config;
use DBI;
use DBD::SQLite                 1.00;
use File::Basename              qw( basename );
use File::Spec::Functions       qw( catfile );
use LWP::Simple                 qw( mirror RC_OK RC_NOT_MODIFIED );
use Regexp::Assemble            0.06;

###########################################################################
# Variables

my $TESTDB  = 'cpanstats.db';
my $TESTURL = 'http://devel.cpantesters.org/cpanstats.db';

#--------------------------------------------------------------------------

###########################################################################
# Public Interface

sub file_allowed {
    my ($self, $file) = @_;
    return (basename($file) eq $TESTDB) ? 1 :
        CPAN::Mini::file_allowed($self, $file);
}

sub mirror_indices {
    my $self = shift;

    warn "test_db_arch is deprecated"   if(defined $self->{test_db_arch});

    $self->{test_db_file} ||= catfile($self->{local}, $TESTDB);
    my $local_file = $self->{test_db_file};

    # test_db_age < 0, do not update it

    my $test_db_age = $self->{test_db_age};
    $test_db_age = 1, unless (defined $test_db_age);

    if (    $self->{force}
         || !-e $local_file
         || (   $test_db_age >= 0
             && -e $local_file
             && -M $local_file > $test_db_age) ) {

        $self->trace($TESTDB);
        my $db_src = $self->{test_db_src} || $TESTURL;
        my $status = mirror($db_src, $local_file);

        if ($status == RC_OK) {
            $self->trace(" ... updated\n");
        } elsif ($status == RC_NOT_MODIFIED) {
            $self->trace(" ... up to date\n");
        } else {
            warn "\n$db_src: $status\n";
            return;
        }
    }

    $self->_connect() if (-r $local_file);

    return CPAN::Mini::mirror_indices($self);
}

sub clean_unmirrored {
    my $self = shift;
    $self->_disconnect();
    return CPAN::Mini::clean_unmirrored($self);
}

###########################################################################
# Private Methods

sub _dbh {
    my $self = shift;
    return $self->{test_db};
}

sub _sth {
    my $self = shift;
    return $self->{test_db_sth};
}

sub _connect {
    my ($self, $database)  = @_;

    $database ||= $self->{test_db_file};
    die "Cannot find database file" unless (-r $database);

    $self->{test_db} = DBI->connect(
        "DBI:SQLite:dbname=".$database, "", "", {
            RaiseError => 1,
            %{$self->{test_db_conn} || { }},
        },
    ) or die "Unable to connect: ", $DBI::errstr;

    # TODO: support for additional reports fields such as perl version

    $self->{test_db_sth} =
        $self->_dbh->prepare( qq{
            SELECT COUNT(id)
              FROM cpanstats
             WHERE status='PASS'
               AND dist=?
               AND version=?
               AND osname=?
    }) or die "Unable to create prepare statement: ", $self->_dbh->errstr;

    return 1;
}

sub _disconnect {
    my $self = shift;
    if ($self->_dbh) {
        $self->_sth->finish if ($self->_sth);
        $self->_dbh->disconnect;
    }
    return 1;
}

sub _check_db {
    my ($self, $dist, $ver, $osname) = @_;

    my $sth = $self->_sth;
    die "Not connected to the database\n"   unless ($sth);

    $sth->execute($dist, $ver, $osname);
    my $row = $sth->fetch;

    return $row->[0]    if($row);
    return 0;
}

sub _reset_cache {
    my $self = shift;
    $self->{test_db_cache} = undef, if ($self->{test_db_cache});
    $self->{test_db_cache} = Cache::Simple::TimedExpiry->new;
    $self->{test_db_cache}->expire_after($self->{test_db_cache_expiry} || 300);
}

sub _passed {
    my ($self, $path) = @_;

    # CPAN::Mini 0.36 no longer calls the filter routine multiple times
    # per module, but it will for packages with multiple modules. So we
    # cache the results, but only for a limited time.

    $self->_reset_cache unless (defined $self->{test_db_cache});

    if ($self->{test_db_exceptions}) {

        if (ref($self->{test_db_exceptions}) eq "CODE") {
            return 1, if ( &{ $self->{test_db_exceptions} }($path) );
        } else {
            my $re = new Regexp::Assemble;

            if (ref($self->{test_db_exceptions}) eq "ARRAY") {
	            $re->add( @{ $self->{test_db_exceptions} } );
            } elsif ( (!ref($self->{test_db_exceptions})) || (ref($self->{test_db_exceptions}) eq "Regexp") ) {
	            $re->add( $self->{test_db_exceptions} );
            } else {
	            die "Unknown test_db_exception type: ", ref($self->{test_db_exceptions});
            }

            return 1, if ($path =~ $re->re);
        }
    }

    return $self->{test_db_cache}->fetch($path) if ($self->{test_db_cache}->has_key($path));

    my $count = 0;

    my $distver = basename($path);
    $distver =~ s/\.(tar\.gz|tar\.bz2|zip)$//;

    my $x       = rindex($distver, '-');
    my $dist    = substr($distver, 0, $x);
    my $ver     = substr($distver, $x+1);

    $self->{test_db_os} ||= $Config{osname};

    if (ref($self->{test_db_os}) eq 'ARRAY') {
        my @archs = @{ $self->{test_db_os} };
        while ( (!$count) && (my $arch = shift @archs) ) {
            $count += $self->_check_db($dist, $ver, $arch);
        }
    } else {
        $count += $self->_check_db($dist, $ver, $self->{test_db_os});
    }

    $self->{test_db_cache}->set($path, $count);

    return $count;
}

# TODO: if filtering in CPAN::Mini is changed to allow paths to be
# munged, then we can add the option to fall back to the latest
# version which passes tests.

sub _filter_module {
    my ($self, $args) = @_;
    return CPAN::Mini::_filter_module($self, $args)
        || (!$self->_passed($args->{path}));
}

1;

__END__