Module::Mask::Deps - Mask modules not listed as dependencies

    perl Build.PL
    PERL_HARNESS_SWITCHES=-MModule::Mask::Deps ./Build test

    use Module::Mask::Deps;

    BEGIN {
        # die if an unlisted module is used
        use_ok('My::Module');
    }

    # turn off masking (at compile time)
    no Module::Mask::Deps;

    # .. or at run-time
    unimport Module::Mask::Deps;

    require Module::Mask::Deps;

    {
        my $mask = new Module::Mask::Deps;

        # Non-dependencies masked until end-of-scope.

        # ... 
    }

    require Arbitrary::Module;

    use Module::Mask::Deps;

    import Module::Mask::Deps;

    unimport Module::Mask::Deps

    no Module::Mask::Deps;

    $obj = $class->new()

    $obj = $obj->set_mask()

    # Will check @INC but won't be masked
    require 't/my_script.pl';

    # Won't even check @INC
    require './t/my_script.pl';

    @deps = $class->get_deps()

    perl -le 'require Module::Mask::Deps; print for keys %INC'

    Module::Mask::Deps: Couldn't find dependencies

package Module::Mask::Deps;

use strict;
use warnings;

our $VERSION = '0.06';

use Module::CoreList;

use Module::Mask;

use File::Spec::Functions qw(
    file_name_is_absolute
    updir
    splitdir
    abs2rel
);

our @ISA = qw( Module::Mask::Inverted );

our $Mask;

sub import {
    my $class = shift;

    if ($Mask) {
        $Mask->set_mask;
    }
    else {
        $Mask = new $class;
    }
}

sub unimport {
    my $class = shift;

    $Mask->clear_mask if $Mask;
}

sub new {
    my $class = shift;

    my @deps = $class->get_deps;

    return $class->SUPER::new(@deps);
}

sub set_mask {
    my $self = shift;

    $self->SUPER::set_mask();
    # now the mask should be at the start of @INC

    # This is less code, but it's not as clear.
    # Might even be less efficient.
    # for (my $i = 1; $self->_rel_path($INC[$i]); $i++) {
        # unshift @INC, splice @INC, $i, 1;
    # }

    # count how many relative paths follow the mask object
    my $count = 0;
    for my $entry (@INC[1 .. $#INC]) {
        if ($self->_rel_path($entry)) {
            $count++;
        }
        else {
            last;
        }
    }

    # move relative entries in front of the mask object
    unshift @INC, splice @INC, 1, $count;

    return $self;
}

sub _rel_path {
    my ($self, $entry) = @_;
    
    return !file_name_is_absolute($entry)
        || (splitdir(abs2rel($entry)))[0] ne updir
}

# prevent sub-dependencies from being masked
sub Module::Mask::Deps::INC {
    my ($self, $module) = @_;

    if ($self->is_masked($module)) {
        my ($call_pack, $call_file) = caller;

        if ($self->_is_listed($call_pack)) {
            # we've explicitly whitelisted the calling package,
            # don't mask its dependencies

            # also add this module to the whitelist
            $self->mask_modules($module);

            return;
        }
        elsif (-f $module) {
            # $module must be a local, relative path.
            # Absolute paths don't check @INC
            # It will be loaded as long as . is in @INC
            return;
        }
        else {
            # Maybe we're being called from a package defined inside a module
            # file 
            my %inc_lookup = reverse %INC;

            # This won't work unless the module is loaded from the filesystem
            my $call_mod = $inc_lookup{$call_file};

            if ($call_mod and $self->_is_listed($call_mod)) {
                # Add the sub-package to the whitelist so we don't need to
                # re-check next time
                $self->mask_modules($call_pack, $module);

                return;
            }
        }
    }

    return $self->SUPER::INC($module);
}

# methods to try to get dependencies from
# subclasses may want to add to this list to get their methods to be called get
# get_deps
our @dep_methods = qw(
    _get_builder_deps
    _get_makefile_deps
);

sub get_deps {
    my $class = shift;

    for my $method (@dep_methods) {
        my @deps = eval { $class->$method };
        last if $@;
        return @deps if @deps;
    }

    die "$class: Couldn't find dependencies\n", $@ ? "$@\n" : '';
}

# get dependencies from Module::Build
# return nothing if this isn't a Module::Build distro, die if something goes
# wrong.
sub _get_builder_deps {
    my $class = shift;

    return unless -f 'Build.PL';

    my $build = do {
        require Module::Build;

        # suppress warnings in current
        local $SIG{__WARN__} = sub {};

        current Module::Build;
    };

    # method names to call to get dependencies from a Module::Build object
    my @dep_fields = qw( requires build_requires );

    # copy and merge all deps.
    my %deps = map { %{$build->$_} } @dep_fields;
    
    # find target perl version, if present.
    my $perl_version = delete $deps{'perl'} || $];

    return $class->_merge_core($perl_version, keys %deps);
}

# get dependencies from ExtUtils::MakeMaker
sub _get_makefile_deps {
    my $class = shift;
    my @deps;

    # return on error, since we might have other _get_*_deps methods to try..
    return unless -f 'Makefile.PL';

    my @cmd = ($^X, 'Makefile.PL', 'PREREQ_PRINT=1');
    local $" = ' ';
    my $code = qx( @cmd );

    if ($code =~ /^ \$PREREQ_PM \s* = \s* {/x) {
        # Let's not eval arbitrary code...
        # We only need the names anyway
        @deps = $code =~ /^\s+'([\w:]+)/mg;
    }
    else {
        die "@cmd returned erroneous code\n";
    }

    return $class->_merge_core($], @deps);
}

# convenience function to return unique deps for a given perl version and
# dependency list
sub _merge_core {
    my ($class, $version, @deps) = @_;
    my @core = $class->_get_core($version);
    my %seen;

    return grep { !$seen{$_}++ } (@core, @deps);
}

# Find core modules for the given perl version
sub _get_core {
    my $class = shift;
    my $perl_version = shift;
    my @core;

    @core = $class->_core_for_version($perl_version);

    return @core if @core;

    # Nothing found,
    # Maybe $perl_version needs reformatting..

    my $clean = $class->_clean_version($perl_version);
    
    @core = $class->_core_for_version($clean);

    return @core if @core;

    # still nothing..

    die "$class: Couldn't find core modules for perl $perl_version\n";
}

# wrap %Module::CoreList::version
sub _core_for_version {
    my $class = shift;
    my $perl_version = shift;

    if (exists $Module::CoreList::version{$perl_version}) {
        return keys %{$Module::CoreList::version{$perl_version}};
    }
    else {
        return;
    }
}

# try to transform perl version numbers into the type used in Module::CoreList
sub _clean_version {
    my ($class, $version) = @_;

    my ($major, @minors) = split(/[._]/, $version);

    # we don't want trailing zeros
    pop @minors while @minors && $minors[-1] == 0;

    @minors = map { sprintf('%03d', $_) } @minors;

    if (@minors > 1 && $major == 5 && $minors[0] >= 3 && $minors[0] < 6) {
        # Between 5.3 and 5.6, the second minor version is 2 digits
        # 5.3.7 => 5.00307
        # 5.5.3 => 5.00503

        $minors[1] =~ s/^0//;
    }

    local $" = '';

    return @minors ? "$major.@minors" : $major;
}

1;

__END__

vim: ts=8 sts=4 sw=4 sr et