File Coverage

blib/lib/Test2/Tools/LoadModule.pm

Criterion	Covered	Total	%
statement	209	213	98.1
branch	65	72	90.2
condition	27	30	90.0
subroutine	44	44	100.0
pod	7	7	100.0
total	352	366	96.1

package Test2::Tools::LoadModule;

use 5.008001;

use strict;
use warnings;

# OK, the following is probably paranoia. But if Perl 7 decides to
# change this particular default I'm ready. Unless they eliminate $].
no if $] ge '5.020', feature => qw{ signatures };

use Carp;
use Exporter 5.567;	# Comes with Perl 5.8.1.
# use File::Find ();
# use File::Spec ();
# use Getopt::Long 2.34;	# Comes with Perl 5.8.1.
use Test2::API ();
use Test2::Util ();

use base qw{ Exporter };

our $VERSION = '0.007';
$VERSION =~ s/ _ //smxg;

{
    my @test2 = qw{
	all_modules_tried_ok
	clear_modules_tried
	load_module_ok
	load_module_or_skip
	load_module_or_skip_all
    };

    my @more = qw{
	require_ok
	use_ok
    };

    my @private = qw{
	__build_load_eval
	__get_hint_hash
	DEFAULT_LOAD_ERROR
	ERR_IMPORT_BAD
	ERR_MODULE_UNDEF
	ERR_OPTION_BAD
	ERR_SKIP_NUM_BAD
	ERR_VERSION_BAD
	HINTS_AVAILABLE
	TEST_MORE_ERROR_CONTEXT
	TEST_MORE_LOAD_ERROR
    };

    our @EXPORT_OK = ( @test2, @more, @private );

    our %EXPORT_TAGS = (
	all		=> [ @test2, @more ],
	default	=> \@test2,
	more	=> \@more,
	private	=> \@private,
	test2	=> \@test2,
    );

    our @EXPORT = @{ $EXPORT_TAGS{default} };	## no critic (ProhibitAutomaticExportation)
}

use constant ARRAY_REF		=> ref [];
use constant HASH_REF		=> ref {};

use constant CALLER_HINT_HASH	=> 10;

use constant DEFAULT_LOAD_ERROR	=> '%s';

use constant ERR_IMPORT_BAD	=>
	'Import list must be an array reference, or undef';
use constant ERR_MODULE_UNDEF	=> 'Module name must be defined';
use constant ERR_OPTION_BAD	=> 'Bad option';
use constant ERR_SKIP_NUM_BAD	=>
	'Number of skipped tests must be an unsigned integer';
use constant ERR_VERSION_BAD	=> q/Version '%s' is invalid/;

use constant HINTS_AVAILABLE	=> $] ge '5.010';

# The following cribbed shamelessly from version::regex 0.9924,
# after being munged to suit by tools/version_regex 0.000_010.
# This technical debt is incurred to avoid having to require a version
# of the version module large enough to export the is_lax() subroutine.
use constant LAX_VERSION	=> qr/(?x: (?x:
	v (?-x:[0-9]+) (?-x: (?-x:\.[0-9]+)+ (?-x:_[0-9]+)? )?
	|
	(?-x:[0-9]+)? (?-x:\.[0-9]+){2,} (?-x:_[0-9]+)?
    ) | (?x: (?-x:[0-9]+) (?-x: (?-x:\.[0-9]+) | \. )? (?-x:_[0-9]+)?
	|
	(?-x:\.[0-9]+) (?-x:_[0-9]+)?
    ) )/;

use constant TEST_MORE_ERROR_CONTEXT	=> q/Tried to %s '%s'./;
use constant TEST_MORE_LOAD_ERROR	=> 'Error:  %s';
use constant TEST_MORE_OPT		=> {
    load_error	=> TEST_MORE_LOAD_ERROR,
    require	=> 1,
};

{
    my %module_tried;

    sub load_module_ok (@) {	## no critic (RequireArgUnpacking)
	my @arg = _validate_args( 0, @_ );

	# We do this now in case _load_module_ok() throws an uncaught
	# exception, just so we have SOME record we tried.
	$module_tried{ $arg[1] } = undef;

	my $ctx = Test2::API::context();

	my $rslt = _load_module_ok( @arg );

	$module_tried{ $arg[1] } = $rslt;

	$ctx->release();

	return $rslt;
    }

    sub all_modules_tried_ok (@) {
	my @where = @_;
	@where
	    or @where = ( 'blib/lib', 'blib/arch' );

	require File::Find;
	require File::Spec;

	my @not_tried;
	foreach my $d ( @where ) {
	    File::Find::find( sub {
		    m/ [.] pm \z /smx
			or return;
		    my ( undef, $dir, $name ) = File::Spec->splitpath(
			File::Spec->abs2rel( $File::Find::name, $d ) );
		    my @dir = File::Spec->splitdir( $dir );
		    $dir[-1]
			or pop @dir;
		    ( my $module = join '::', @dir, $name ) =~ s/ [.] pm //smx;
		    exists $module_tried{$module}
			or push @not_tried, $module;
		}, $d );
	}

	if ( @not_tried ) {

	    my $ctx = Test2::API::context();

	    $ctx->fail( "Module $_ not tried" ) for sort @not_tried;

	    $ctx->release();

	    return 0;
	}
    }

    sub clear_modules_tried () {
	%module_tried = ();
	return;
    }
}

sub _load_module_ok {
    my ( $opt, $module, $version, $import, $name, @diag ) = @_;

    local $@ = undef;

    my $eval = __build_load_eval( $opt, $module, $version, $import );

    defined $name
	or $name = $eval;

    my $ctx = Test2::API::context();

    _eval_in_pkg( $eval, $ctx->trace()->call() )
	and return $ctx->pass_and_release( $name );

    chomp $@;

    $opt->{load_error}
	and push @diag, sprintf $opt->{load_error}, $@;

    return $ctx->fail_and_release( $name, @diag );
}

sub load_module_or_skip (@) {	## no critic (RequireArgUnpacking,RequireFinalReturn)
    my ( $opt, $module, $version, $import, $name, $num ) = _validate_args( 5, @_ );

    _load_module( $opt, $module, $version, $import )
	and return;

    defined $name
	or $name = sprintf 'Unable to %s',
	    __build_load_eval( $opt, $module, $version, $import );
    defined $num
	and $num =~ m/ [^0-9] /smx
	and croak ERR_SKIP_NUM_BAD;

    my $ctx = Test2::API::context();
    $num ||= 1;
    $ctx->skip( 'skipped test', $name ) for 1 .. $num;

    $ctx->release();
    no warnings qw{ exiting };
    last SKIP;
}

sub load_module_or_skip_all (@) {	## no critic (RequireArgUnpacking)
    my ( $opt, $module, $version, $import, $name ) = _validate_args( 4, @_ );

    _load_module( $opt, $module, $version, $import )
	and return;

    defined $name
	or $name = sprintf 'Unable to %s',
	    __build_load_eval( $opt, $module, $version, $import );

    my $ctx = Test2::API::context();
    $ctx->plan( 0, SKIP => $name );
    $ctx->release();

    return;
}

sub _load_module {
    my ( $opt, $module, $version, $import ) = @_;

    local $@ = undef;

    my $eval = __build_load_eval( $opt, $module, $version, $import );

    return _eval_in_pkg( $eval, _get_call_info() )
}

{
    my $psr;

    # Because we want to work with Perl 5.8.1 we are limited to
    # Getopt::Long 2.34, and therefore getoptions(). So we expect the
    # arguments to be in a suitably-localized @ARGV. The optional
    # argument is a reference to a hash into which we place the option
    # values. If omitted, we create a reference to a new hash. Either
    # way the hash reference gets returned.
    sub _parse_opts {
	my ( $opt ) = @_;
	$opt ||= {};
	{
	    unless ( $psr ) {
		require Getopt::Long;
		Getopt::Long->VERSION( 2.34 );
		$psr = Getopt::Long::Parser->new();
		$psr->configure( qw{ posix_default } );
	    }

	    my $opt_err;
	    local $SIG{__WARN__} = sub { $opt_err = $_[0] };
	    $psr->getoptions( $opt, qw{
		    load_error=s
		    require|req!
		},
	    ) or do {
		if ( defined $opt_err ) {
		    chomp $opt_err;
		    croak $opt_err;
		} else {
		    croak ERR_OPTION_BAD;
		}
	    };
	}
	if ( $opt->{load_error} ) {
	    $opt->{load_error} =~ m/ ( %+ ) [ #0+-]* [0-9]* s /smx
		and length( $1 ) % 2
		or $opt->{load_error} = '%s';
	}
	return $opt;
    }
}

sub import {	## no critic (RequireArgUnpacking,ProhibitBuiltinHomonyms)
    ( my $class, local @ARGV ) = @_;	# See _parse_opts
    if ( @ARGV ) {
	my %opt;
	_parse_opts( \%opt );
	if ( HINTS_AVAILABLE ) {
	    $^H{ _make_pragma_key() } = $opt{$_} for keys %opt;
	} else {
	    keys %opt
		and carp "Import options ignored under Perl $]";
	}
	@ARGV
	    or return;
    }
    return $class->export_to_level( 1, $class, @ARGV );
}

sub require_ok ($) {
    my ( $module ) = @_;
    defined $module
	or croak ERR_MODULE_UNDEF;
    my $ctx = Test2::API::context();
    my $rslt = _load_module_ok( TEST_MORE_OPT,
	$module, undef, undef, "require $module;",
	sprintf( TEST_MORE_ERROR_CONTEXT, require => $module ),
    );
    $ctx->release();
    return $rslt;
}

sub use_ok ($;@) {
    my ( $module, @arg ) = @_;
    defined $module
	or croak ERR_MODULE_UNDEF;
    my $version = ( defined $arg[0] && $arg[0] =~ LAX_VERSION ) ?
	shift @arg : undef;
    my $ctx = Test2::API::context();
    my $rslt = _load_module_ok( TEST_MORE_OPT,
	$module, $version, \@arg, undef,
	sprintf( TEST_MORE_ERROR_CONTEXT, use => $module ),
    );
    $ctx->release();
    return $rslt;
}

sub _make_pragma_key {
    return join '', __PACKAGE__, '/', $_;
}

sub _caller_class {
    my ( $lvl ) = @_;
    my ( $pkg ) = caller( $lvl || 1 );
    my $code = $pkg->can( 'CLASS' )
	or croak ERR_MODULE_UNDEF;
    return $code->();
}

{

    my %default_hint = (
	load_error	=> DEFAULT_LOAD_ERROR,
    );

    sub __get_hint_hash {
	my ( $level ) = @_;
	$level ||= 0;
	my $hint_hash = ( caller( $level ) )[ CALLER_HINT_HASH ];
	my %rslt = %default_hint;
	if ( HINTS_AVAILABLE ) {
	    foreach ( keys %{ $hint_hash } ) {
		my ( $hint_pkg, $hint_key ) = split qr< / >smx;
		__PACKAGE__ eq $hint_pkg
		    and $rslt{$hint_key} = $hint_hash->{$_};
	    }
	}
	return \%rslt;
    }
}

sub __build_load_eval {
    my @arg = @_;
    HASH_REF eq ref $arg[0]
	or unshift @arg, {};
    my ( $opt, $module, $version, $import ) = @arg;
    my @eval = "use $module";

    defined $version
	and push @eval, $version;

    if ( $import && @{ $import } ) {
	push @eval, "qw{ @{ $import } }";
    } elsif ( defined $import xor not $opt->{require} ) {
	# Do nothing.
    } else {
	push @eval, '()';
    }

    return "@eval;";
}

sub _validate_args {
    ( my $max_arg, local @ARGV ) = @_;
    my $opt = _parse_opts( __get_hint_hash( 2 ) );

    if ( $max_arg && @ARGV > $max_arg ) {
	( my $sub_name = ( caller 1 )[3] ) =~ s/ .* :: //smx;
	croak sprintf '%s() takes at most %d arguments', $sub_name, $max_arg;
    }

    my ( $module, $version, $import, $name, @diag ) = @ARGV;

    defined $module
	or $module = _caller_class( 2 );

    if ( defined $version ) {
	$version =~ LAX_VERSION
	    or croak sprintf ERR_VERSION_BAD, $version;
    }

    not defined $import
	or ARRAY_REF eq ref $import
	or croak ERR_IMPORT_BAD;

    return ( $opt, $module, $version, $import, $name, @diag );
}

sub _eval_in_pkg {
    my ( $eval, $pkg, $file, $line ) = @_;

    my $e = <<"EOD";
package $pkg;
#line $line "$file"
$eval;
1;
EOD

    # We need the stringy eval() so we can mess with Perl's concept of
    # what the current file and line number are for the purpose of
    # formatting the exception, AND as a convenience to get symbols
    # imported.
    my $rslt = eval $e;	## no critic (ProhibitStringyEval)

    return $rslt;
}

sub _get_call_info {
    my $lvl = 0;
    while ( my @info = caller $lvl++ ) {
	__PACKAGE__ eq $info[0]
	    and next;
	$info[1] =~ m/ \A [(] eval \b /smx	# )
	    or return @info;
    }
    confess 'Bug - Unable to determine caller';
}

1;

__END__