File Coverage

blib/lib/Test/NoXS.pm

Criterion	Covered	Total	%
statement	45	46	97.8
branch	14	20	70.0
condition	1	3	33.3
subroutine	11	11	100.0
pod			n/a
total	71	80	88.7

use 5.006;
use strict;
use warnings;

package Test::NoXS;
# ABSTRACT: Prevent a module from loading its XS code
our $VERSION = '1.03'; # VERSION

use Module::CoreList 3.00;
require DynaLoader;
require XSLoader;

my @no_xs_modules;
my $no_xs_all;
my $xs_core_only;
my $xs_core_or_dual;

our $PERL_CORE_VERSION = sprintf( "%vd", $^V );

sub import {
    my $class = shift;
    if ( grep { /:all/ } @_ ) {
        $no_xs_all = 1;
    }
    elsif ( grep { /:xs_core_only/ } @_ ) {
        $xs_core_only = 1;
    }
    elsif ( grep { /:xs_core_or_dual/ } @_ ) {
        $xs_core_or_dual = 1;
    }
    else {
        push @no_xs_modules, @_;
    }
}

sub _assert_module {
    my $module = shift;
    die "XS disabled\n" if $no_xs_all;
    die "XS disabled for $module\n" if grep { $module eq $_ } @no_xs_modules;
    _assert_in_core($module) if $xs_core_or_dual || $xs_core_only;
    _assert_exact_core_version($module) if $xs_core_only;
    return 1;
}

sub _assert_in_core {
    my $module = shift;
    # Uses explicit $PERL_CORE_VERSION instead of default for testing
    die "XS disabled for non-core modules"
      unless Module::CoreList::is_core( $module, undef, $PERL_CORE_VERSION );
    return 1;
}

sub _assert_exact_core_version {
    my $module = shift;
    # Uses explicit $PERL_CORE_VERSION instead of default for testing
    my $core_module_version = $Module::CoreList::version{$PERL_CORE_VERSION}{$module};
    my $module_version      = $module->VERSION;
    if ( $core_module_version ne $module_version ) {
        die "$module installed version: $module_version"
          . " ne $core_module_version ( shipped with perl $PERL_CORE_VERSION )";
    }
    return 1;
}

# Overload DynaLoader and XSLoader to fake lack of XS for designated modules
for my $orig (qw/DynaLoader::bootstrap XSLoader::load/) {
    local $^W;
    no strict 'refs';
    no warnings 'redefine';
    my $coderef = *{$orig}{CODE};
    *{$orig} = sub {
        my $caller = @_ ? $_[0] : caller;
        _assert_module($caller);
        goto $coderef;
    };
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__