File Coverage

blib/lib/Test/Distribution.pm

Criterion	Covered	Total	%
statement	162	214	75.7
branch	16	56	28.5
condition	10	17	58.8
subroutine	38	47	80.8
pod	3	4	75.0
total	229	338	67.7

package Test::Distribution;

# pragmata
use strict;
use vars qw($VERSION @default_types @supported_types);
use warnings;

# perl modules
use ExtUtils::Manifest qw(manicheck);
use Test::More;


$VERSION = '2.00';

@default_types = qw/manifest use versions prereq pod description podcover/;
@supported_types = qw/manifest use versions prereq pod description podcover sig/;

my @error;
for (qw/File::Spec File::Basename File::Find::Rule/) {
	eval "require $_";
	push @error => $_ if $@;
}
if (@error) {
	# construct a nice message with proper placement of commas and
	# the verb 'to be' in the enumeration of the error(s)

	@error = sort @error;
	my $is = @error == 1 ? 'is' : 'are';
	my $last = pop @error;
	my $msg = join ', ' => @error;
	$msg .= ' and ' if length $msg;
	$msg .= "$last $is required for Test::Distribution";
	plan skip_all => $msg;
	exit;
}

# This runs during BEGIN

sub import {
	return if our $been_here++;
	my $pkg = shift;
	my %args = @_;

	use vars qw(@default_types);
	$args{only} ||= \@default_types;
	$args{only} = [ $args{only} ] unless ref $args{only} eq 'ARRAY';

	$args{not} ||= [];
	$args{not} = [ $args{not} ] unless ref $args{not} eq 'ARRAY';

	$args{tests} ||= 0;

	$args{dirlist} = [ qw(blib lib) ];
	$args{dir}   ||= File::Spec->catfile(@{ $args{dirlist} });

	$args{podcoveropts} ||= {};

	run_tests(\%args);
}

# This runs after CHECK, i.e. at run-time

sub run_tests {
	my $args = shift;
	my %args = %$args;

	our @files = -d $args{dir} ? File::Find::Rule->file()->name('*.pm')->in($args{dir}) : ();

	our @packages = map {
	    # $_ is like 'blib/lib/Foo/Bar/Baz.pm',
	    # after splitpath: $dir is 'blib/lib/Foo/Bar', $file is 'Baz.pm',
	    # after splitdir: @dir is qw(blib lib Foo Bar),
	    # after shifting off @{$args{dirlist}}, @dir is qw(Foo Bar),
	    # so now we can portably construct the package name.

	    my ($vol, $dir, $file) = File::Spec->splitpath($_);
	    my @dir = grep { length } File::Spec->splitdir($dir);
	    shift @dir for @{ $args{dirlist} };
	    join '::' => @dir, File::Basename::basename($file, '.pm');
	    } @files;

	my %perform;
	%perform = map { $_ => 1 } @{$args{only}};
	delete @perform{ @{$args{not}} };

	# need to use() modules before we can check their $VERSIONS,
	# so we might as well test with use_ok().

	$perform{use} = 1 if $perform{versions};

	our %testers;
	our $tests = $args{tests};
	for my $type (keys %perform) {
		die "no such test type: $type\n"
		    unless grep /^$type$/ => our @supported_types;

		my $pkg = __PACKAGE__ . '::' . $type;
		$testers{$type} = $pkg->new(
		    packages => \@packages,
		    files    => \@files,
		    %args,
		);

		$tests += $testers{$type}->num_tests;
	}

	plan tests => $tests;

	for my $type (@supported_types) {
		$testers{$type}->run_tests($args) if $perform{$type};
	}
}

sub packages  { our @packages }
sub files     { our @files }
sub num_tests { our $tests }

package Test::Distribution::base;

sub new {
	my ($class, %args) = @_;
	bless \%args, $class;
}

sub num_tests { 0 }
sub run_tests {}


package Test::Distribution::pod;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests { scalar @{ $_[0]->{files} } }

sub run_tests { SKIP: {
	my $self = shift;

	eval {
		require Test::Pod;
		Test::Pod->import;
	};
	skip 'Test::Pod required for testing POD', $self->num_tests() if $@;

	for my $file (@{ $self->{files} }) { pod_file_ok($file) }
} }


package Test::Distribution::podcover;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests { scalar @{ $_[0]->{packages} } }

sub run_tests { SKIP: {
	my $self = shift;
	my $args = shift;

	eval {
		require Test::Pod::Coverage;
		Test::Pod::Coverage->import;
	};
	skip 'Test::Pod::Coverage required for testing POD', $self->num_tests() if $@;

	my $trustme = $args->{podcoveropts};
	for my $package (@{ $self->{packages} }) { pod_coverage_ok($package, $trustme, 'Pod Coverage ok') }
} }


package Test::Distribution::use;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests { scalar @{ $_[0]->{packages} } }

sub run_tests {
	my $self = shift;
	for my $package (@{ $self->{packages} }) { use_ok($package) }
}


package Test::Distribution::versions;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests {
   my $self = shift;

   my $num_packages = scalar @{ $self->{packages} };

   if($self->{distversion}) {
       return $num_packages * 2 - 1;  # Don't test package itself to see if its own dist version matches
   }
   else {
       return $num_packages;
   }

}

sub run_tests {
	my $self = shift;

	for my $package (@{ $self->{packages} }) {
	    our $version;

	    my $this_version = do {
		no strict 'refs';
	     	${"$package\::VERSION"}
    	    };

	    unless (defined $version) {
		$version = $this_version;
		ok(defined($version), "$package defines a version");
		next;
	    }

    	    ok(defined($version), "$package defines a version");

	    if($self->{distversion}) {
		is($this_version, $version, "$package version matches");
	    }
	}
}


package Test::Distribution::description;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests { 4 }

sub run_tests {
	my $self = shift;
	ok(-e, "$_ exists") for qw/MANIFEST README/;
  ok(-e 'Changes' || -e 'ChangeLog' || -e 'Changes.pod' || -e 'ChangeLog.pod', 'Changes(.pod)? or ChangeLog(.pod)? exists');
	ok(-e 'Build.PL' || -e 'Makefile.PL', 'Build.PL or Makefile.PL exists');
}


package Test::Distribution::manifest;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests { 1 }

sub run_tests {
    my $self = shift;

    my @missing_files = ExtUtils::Manifest::manicheck();
    ok(scalar @missing_files == 0, "Checking MANIFEST integrity");
}


package Test::Distribution::prereq;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests { 1 }

sub run_tests { SKIP: {
	my $self = shift;

	eval {
		require File::Find::Rule;
		require Module::CoreList;
	};
	skip 'Module::Build PREREQ_PM not yet implemented', $self->num_tests() if -f 'Build.PL';
	skip 'File::Find::Rule and Module::CoreList required for testing PREREQ_PM', $self->num_tests() if $@;
	skip "testing PREREQ_PM not implemented for perl $] because Module::CoreList doesn't know about it", $self->num_tests unless
        exists $Module::CoreList::version{ $] };

	my (%use, %package);

	File::Find::Rule->file()->nonempty()->or(
	    File::Find::Rule->name(qr/\.p(l|m|od)$/),
	    File::Find::Rule->exec(sub {
		my $fh;
		return 0 unless open $fh, $_;
		my $shebang = <$fh>;
		close $fh;
		return $shebang =~ /^#!.*\bperl/;
	    }),
	)->exec(sub {
	    my $fh;
	    return 0 unless open $fh, $_;
	    while (<$fh>) {
		    $use{$1}++ if /^use \s+ ([^\W\d][\w:]+) (\s*\n | .*;)/x;
		    $package{$1}++ if /^package \s+ ([\w:]+) \s* ;/x;
	    }
	    return 1;
	})->in($self->{dir});

	# We're not interested in use()d modules that are provided by
	# this distro, or in core modules. It's ok core modules aren't
	# mentioned in PREREQ_PM.

	no warnings 'once';
	delete @use{ keys %package, keys %{ $Module::CoreList::version{$]} } };

	open my $fh, 'Makefile.PL' or die "can't open Makefile.PL: $!\n";
	my $make = do { local $/; <$fh> };
	close $fh or die "can't close Makefile.PL: $!\n";
	$make =~ s/use \s+ ExtUtils::MakeMaker \s* ;/no strict;/gx;

	$make .= 'sub WriteMakefile {
	    my %h = @_; our @prereq = keys %{ $h{PREREQ_PM} || {} } }';
	eval $make;
	die $@ if $@;

	delete @use{our @prereq};
	ok(keys(%use) == 0, 'All non-core use()d modules listed in PREREQ_PM')
	  or diag(prereq_error(%use));
} }

# construct an error message for test output
sub prereq_error {
    my %use = @_;
    my @modules = sort keys %use;
    (@modules > 1 ? 'These modules are' : 'A module is') .
      " used but not mentioned in Makefile.PL's PREREQ_PM:\n" .
      join "\n" => map { "  $_" } @modules;
}

# XXX - not yet implemented and no docs or tests yet.
package Test::Distribution::exports;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests { 0 }

sub run_tests {
	my $self = shift;
}

package Test::Distribution::sig;
use Test::More;
our @ISA = 'Test::Distribution::base';

sub num_tests {
	return (-f 'SIGNATURE') ? 1 : 0;
}

sub run_tests { SKIP: {
	my $self = shift;
	return unless $self->num_tests();
	eval {
		require Module::Signature;
		Module::Signature->import;
	};
	if($@) {
		skip 'Module::Signature required for this test', $self->num_tests();
	}
	else {
		my $ret = Module::Signature::verify();
    skip "Module::Signature cannot verify", 1 if $ret eq Module::Signature::CANNOT_VERIFY();

    cmp_ok $ret, '==', Module::Signature::SIGNATURE_OK(), "Valid signature";
	}
} }
1;

__END__