File Coverage

blib/lib/Test/Prereq/Meta.pm

Criterion	Covered	Total	%
statement	242	249	97.1
branch	70	90	77.7
condition	35	58	60.3
subroutine	41	41	100.0
pod	5	5	100.0
total	393	443	88.7

package Test::Prereq::Meta;

use 5.010;	# because Module::Extract::Use has this.

use strict;
use warnings;

use Carp;
use CPAN::Meta;
use Exporter qw{ import };
use ExtUtils::Manifest ();
use File::Find ();
use File::Glob ();
use File::Spec;
use Module::Extract::Use;
use Module::CoreList 2.13;
use Module::Metadata;
use Scalar::Util ();
use Test::More 0.88;

our $VERSION = '0.004';

our @EXPORT_OK = qw{ all_prereq_ok file_prereq_ok prereq_ok };
our %EXPORT_TAGS = (
    all	=> \@EXPORT_OK,
);

# Hash lifted verbatim from File::Spec 3.78 published 2018-08-29
use constant DEFAULT_PATH_TYPE	=> {
    MSWin32 => 'Win32',
    os2     => 'OS2',
    VMS     => 'VMS',
    NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
    symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
    dos     => 'OS2',   # Yes, File::Spec::OS2 works on DJGPP.
    cygwin  => 'Cygwin',
    amigaos => 'AmigaOS',
}->{$^O} || 'Unix';

use constant REF_ARRAY	=> ref [];

sub new {
    my ( $class, %arg ) = @_;

    $arg{file_error} //= 'Failed to analyze %f: %e';
    $arg{name} //= 'Prereq test: %f uses %m';
    # NOTE that {path_type} is unsupported, and may change or be
    # retracted without warning. I thought I needed it to support
    # argument {prune}, which is itself experimental.
    $arg{path_type} //= DEFAULT_PATH_TYPE;
    $arg{per_file_note} //= '%f';
    $arg{perl_version} //= 'none';
    $arg{skip_name} //= 'Prereq test: %f does not use any modules';

    state $default = {
	accept	=> [],
	meta_file	=> [ qw{
	    MYMETA.json MYMETA.yml META.json META.yml } ],
	prune	=> [],
	uses	=> [],
	verbose	=> (
	    scalar grep { -d } qw{ .bzr .cdv .git .hg .svn CVS } ) ? 1 : 0,
    };
    foreach my $name ( keys %{ $default } ) {
	$arg{$name} //= $default->{$name};
	my $code = __PACKAGE__->can( "__validate_$name" ) ||
	    __PACKAGE__->can( '__validate_' . ref $default->{$name} ) ||
	    sub {};
	$code->( $name, \%arg );
    }

    my $core_modules = _get_corelist_version( $arg{perl_version} )
	or croak( "Unknown 'perl_version' $arg{perl_version}" );

    # The below is pretty much verbatim from the CPAN::Meta synopsis

    my $meta_data = $arg{_meta_file};

    my %requires;

    my $prereqs = $meta_data->effective_prereqs();
    foreach my $phase ( qw{ configure build test runtime } ) {
	my $reqs = $prereqs->requirements_for( $phase, 'requires' );
	foreach my $module ( $reqs->required_modules() ) {
	    $requires{$module} = {};
	}
    }

    # The above is pretty much verbatim from the CPAN::Meta synopsis

    # NOTE that if we actually need the Perl version, we need to nab it
    # before here.
    delete $requires{perl};

    my $provides = _provides();

    my %has = map { $_ => 1 }
	@{ $arg{accept} },
	keys %{ $core_modules },
	keys %{ $provides },
	keys %requires,
	;

    $arg{uses} = { map { $_ => 1 } @{ $arg{uses} } };

    if ( $arg{verbose} ) {
	my @dup;
	@dup = grep { $requires{$_} } @{ $arg{accept} }
	    and diag "The following @{[
		@dup == 1 ? 'module appears' : 'modules appear'
		]} in both the prerequisites and\nthe 'accept' argument: ",
		join ', ', sort @dup;
	@dup = grep { $arg{uses}{$_} } @{ $arg{accept} }
	    and diag "The following @{[
		@dup == 1 ? 'module appears' : 'modules appear'
		]} in both the 'accept' argument and\nthe 'uses' argument: ",
		join ', ', sort @dup;
    }

    delete $arg{accept};
    delete $arg{_meta_file};
    delete $arg{path_type};

    my $self = bless {
	# accept		=> $arg{accept},
	# core_modules	=> $core_modules,
	file_error	=> delete $arg{file_error},
	has		=> \%has,
	meta_file	=> delete $arg{meta_file},
	meta_data	=> $meta_data,
	name		=> delete $arg{name},
	per_file_note	=> delete $arg{per_file_note},
	perl_version	=> delete $arg{perl_version},
	prune		=> delete $arg{prune},
	# provides	=> $provides,
	skip_name	=> delete $arg{skip_name},
	uses		=> delete $arg{uses},
	verbose		=> delete $arg{verbose},
	_both_tools	=> ( -e 'Makefile.PL' && -e 'Build.PL' ),
	_normalize_path	=> delete $arg{_normalize_path},
	_requires	=> \%requires,
    }, ref $class || $class;

    if ( my $num = keys %arg ) {
	croak "Unknown argument@{[ $num > 1 ? 's' : '' ]} ", join ', ',
	    map { "'$_'" } sort keys %arg;
    }

    return $self;
}

sub all_prereq_ok {
    my ( $self, @file ) = _unpack_args( @_ );

    unless( @file ) {
	@file = (
	    ( grep { -d } qw{ blib/arch blib/lib blib/script t } ),
	    ( map { File::Spec->abs2rel( $_ ) }
		File::Glob::bsd_glob( '*.PL' ) ),
	);
    }

    my $need_skip = 1;
    my $ok = 1;

    File::Find::find(
	{
	    wanted	=> sub {
		if ( $self->{_normalize_path} ) {
		    $self->{_normalize_path}->();
		    if ( $self->{prune}{$_} ) {
			$File::Find::prune = 1;
			return;
		    }
		}
		_is_perl( $_ )
		    or return;
		# The following is because File::Find tends to give us
		# './fubar' if 'fubar' is in the current directory.
		$_ = File::Spec->abs2rel( $_ );
		$need_skip = 0;
		$self->file_prereq_ok( $_ )
		    or $ok = 0;
		return;
	    },
	    no_chdir	=> 1,
	    preprocess	=> sub { return( sort @_ ) },
	},
	@file,
    );

    if ( $need_skip ) {
	state $TEST = Test::More->builder();
	local $Test::Builder::Level = _nest_depth();
	# $TEST->skip( "$file does not use any modules" );
	$TEST->skip( 'No Perl files found' );
    }

    return $ok;
}

sub all_prereqs_used {
    my ( $self ) = @_;

    state $TEST = Test::More->builder();
    local $Test::Builder::Level = _nest_depth();

    $TEST->note( '' );

    my @unused = sort
	grep { ! $self->{uses}{$_} && ! $self->{_requires}{$_}{file} }
	keys %{ $self->{_requires} };
    my $rslt = $TEST->ok( ! @unused, 'All required modules are used' )
	or $TEST->diag( "The following @{[
	    @unused == 1 ? 'prerequisite is' : 'prerequisites are'
	    ]} unused: ", join ', ', @unused );

    if ( $self->{verbose} and
	my @dup = grep { $self->{_requires}{$_}{file} && $self->{uses}{$_} }
	keys %{ $self->{_requires} }
    ) {
	$TEST->diag( "The following @{[
	    @dup == 1 ? 'module appears' : 'modules appear'
	    ]} in both 'use' statements and\nthe 'uses' argument: ",
	    join ', ', sort @dup );
    }

    return $rslt;
}

sub file_prereq_ok {
    my ( $self, $file, @arg ) = _unpack_args( @_ );
    @arg
	and confess(
	'Usage: $tpm->file_prereq_ok( $file ) or file_prereq_ok( $file )' );

    # Because this gets us a pre-built object I use $Test::Builder::Level
    # (localized) to get tests reported relative to the correct file and
    # line, rather than setting the 'level' attribute.
    state $TEST = Test::More->builder();
    local $Test::Builder::Level = _nest_depth();

    if ( $self->{per_file_note} ne '' ) {
	# We are not interested in the actual test number, but we need
	# to know how many digits it is so that the note can be indented
	# properly.
	$TEST->note( '' );
	$TEST->note(
	    ' ' x ( 4 + length( $TEST->current_test() + 1 ) ),
	    _format(
		$self->{per_file_note},
		{
		    e	=> '',
		    f	=> $file,
		    m	=> '',
		}
	    ),
	);
    }

    my $need_skip = 1;
    my $ok = 1;
    my %module_found;

    state $extor = Module::Extract::Use->new();

    my $modules = $extor->get_modules_with_details( $file );
    if ( my $err = $extor->error() ) {
	$TEST->ok( 0,
	    _format(
		$self->{file_error},
		{
		    e	=> $err,
		    f	=> $file,
		    m	=> '',
		},
	    )
	);
	return 0;
    }

    foreach my $usage (
	sort { $a->{module} cmp $b->{module} }
	@{ $modules }
    ) {
	my $module = $usage->{module};

	# The following is needed because Module::Extract::Use tries too
	# hard to find return() statements embedded in other statements.
	$module =~ m/ \A [\w:]+ \z /smx
	    or next;

	# The following is needed because Module::Extract::Use returns
	# duplicate 'require' statements because it finds them both in
	# the scan for PPI::Statement::Include objects and in the scan
	# for PPI::Token::Word 'require' objects.
	$module_found{$module}++
	    and next;

	$self->{_requires}{$module}
	    and push @{ $self->{_requires}{$module}{file} ||= [] }, $file;

	state $toolchain = {
	    'Makefile.PL'	=> {
		'ExtUtils::MakeMaker'	=> 1,
		'inc::Module::Install'	=> 1,
	    },
	    'Build.PL'		=> {
		'Module::Build'		=> 1,
		'Module::Build::Tiny'	=> 1,
	    },
	};

	$need_skip = 0;
	$TEST->ok(
	    $self->{has}{$module} ||
	    $self->{_both_tools} && $toolchain->{$file}{$module} ||
	    0,
	    _format(
		$self->{name},
		{
		    e	=> '',
		    f	=> $file,
		    m	=> $module,
		},
	    ),
	) or $ok = 0;

    }

    if ( $need_skip ) {
	local $Test::Builder::Level = _nest_depth();
	# $TEST->skip( "$file does not use any modules" );
	$TEST->skip( _format(
		$self->{skip_name},
		{
		    e	=> '',
		    f	=> $file,
		    m	=> '',
		},
	    ),
	);
    }

    return $ok;
}

sub _format {
    my ( $tplt, $sub ) = @_;
    $tplt =~ s| % ( . ) | $sub->{$1} // $1 |smxge;
    return $tplt;
}

sub prereq_ok {
    my ( $perl_version, $name, $accept ) = @_;
    my $self = __PACKAGE__->new(
	accept		=> $accept,
	name		=> $name,
	perl_version	=> $perl_version // $],
    );
    return $self->all_prereq_ok();
}

sub _get_corelist_version {
    my ( $perl_ver ) = @_;

    $perl_ver eq 'none'
	and return {};

    $perl_ver eq 'this'
	and $perl_ver = $];

    my $data;
    $data = $Module::CoreList::version{$perl_ver}
	and return $data;

    # The following is needed under very old versions of
    # Module::CoreList -- pre-2.14 I think.
    $perl_ver =~ s/ 0+ \z //smx;
    return $Module::CoreList::version{$perl_ver};
}

sub _is_perl {
    my ( $file ) = @_;
    -T $file
	or return 0;
    $file =~ m/ [.] (?: (?i: pl ) | pm | t ) \z /smx
	and return 1;
    open my $fh, '<', $file
	or return 0;
    local $_ = <$fh>;
    close $fh;
    defined
	or return 0;
    return m/ \A [#]! .* perl /smx;
}

{
    my %ignore;
    BEGIN {
	%ignore = map { $_ => 1 } __PACKAGE__, qw{ DB File::Find };
    }

    sub _nest_depth {
	my $nest = 0;
	$nest++ while $ignore{ caller( $nest ) || '' };
	return $nest;
    }
}

# All the __normalize_path_* subroutines operate on $_. They take no
# arguments and return nothing relevant. The names are File::Spec::
# OS-specific class names, and the intent is that anything supported by
# File::Spec should appear here.

sub __normalize_path_AmigaOS {}	# Assumed based on File::Spec::AmigaOS

sub __normalize_path_Cygwin {}	# I believe.

sub __normalize_path_OS2 { s| \\ |/|smxg; }	## no critic (RequireFinalReturn)

sub __normalize_path_Unix {}

sub __normalize_path_VMS {
    croak( 'Can not normalize VMS paths' );
}

sub __normalize_path_Win32 { s| \\ |/|smxg; }	## no critic (RequireFinalReturn)

# We don't use Module::Metadata->provides(), because it filters out
# private packages. While we're at it, we just process every .pm we find.
sub _provides {
    my %provides;
    my $manifest = ExtUtils::Manifest::maniread();
    foreach my $file ( keys %{ $manifest } ) {
	$file =~ m/ [.] pm \z /smx
	    or next;
	my $info = Module::Metadata->new_from_file( $file )
	    or next;
	foreach my $module ( $info->packages_inside() ) {
	    state $ignore = { map { $_ => 1 } qw{ main DB } };
	    $ignore->{$module}
		and next;
	    $provides{$module} = 1;
	}
    }
    return \%provides;
}

sub _unpack_args {
    my @arg = @_;
    my $self = ( ref( $arg[0] ) && ref( $arg[0] )->isa( __PACKAGE__ ) ) ?
	shift @arg :
	__PACKAGE__->new();
    return ( $self, @arg );
}

sub __validate_meta_file {
    my ( $name, $arg ) = @_;
    if ( Scalar::Util::blessed( $arg->{$name} ) &&
	$arg->{$name}->isa( 'CPAN::Meta' )
    ) {
	$arg->{"_$name"} = $arg->{$name};
	return;
    }
    __validate_ARRAY( $name, $arg );
    @{ $arg->{$name} }
	or croak( "'$name' must specify at least one file" );
    foreach my $fn ( @{ $arg->{$name} } ) {
	local $@ = undef;
	eval {
	    $arg->{"_$name"} = CPAN::Meta->load_file( $fn );
	} or next;
	$arg->{$name} = $fn;
	return;
    }
    1 == @{ $arg }
	and croak( "$arg->{$name}[0] not readable" );
    local $" = ', ';
    croak( "None of @{ $arg->{$name} } readable" );
}

sub __validate_prune {
    my ( $name, $arg ) = @_;
    __validate_ARRAY( $name, $arg );
    my %rslt;
    foreach ( @{ $arg->{$name} } ) {
	$arg->{_normalize_path} ||= __PACKAGE__->can(
	    "__normalize_path_$arg->{path_type}" )
	|| croak( "Invalid path type '$arg->{path_type}'" );
	$arg->{_normalize_path}->();
	$rslt{$_} = 1;
    }
    $arg->{_normalize_path} ||= undef;
    $arg->{$name} = \%rslt;
    return;
}

sub __validate_ARRAY {
    my ( $name, $arg ) = @_;
    ref $arg->{$name}
	or $arg->{$name} = [ $arg->{$name} ];
    REF_ARRAY eq ref $arg->{$name}
	or croak( "'$name' must be a SCALAR or an ARRAY reference" );
    return;
}

1;

__END__