view release on metacpan or  search on metacpan

lib/Test2/Tools/LoadModule.pm  view on Meta::CPAN

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 ];