# Copyright 2010, 2011, 2012, 2015 Kevin Ryde
# This file is part of Test-VariousBits.
#
# Test-VariousBits is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Test-VariousBits is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Test-VariousBits. If not, see <http://www.gnu.org/licenses/>.
package Module::Util::Masked;
require 5;
use strict;
use vars qw($VERSION);
$VERSION = 6;
# uncomment this to run the ### lines
#use Smart::Comments;
# BEGIN {
# # Check that Module::Util isn't already loaded.
# #
# # is_valid_module_name() here is a representative func, and not one that's
# # mangled here (so as not to risk hitting that if something goes badly
# # wrong). Maybe looking at %INC would be better.
# #
# if (Module::Util->can('is_valid_module_name')) {
# die "Module::Util already loaded, cannot fake after imports may have grabbed its functions";
# }
# }
use Module::Util;
# Crib notes:
#
# Module::Util uses File::Find which loads Scalar::Util, so the requires of
# that here are unnecessary, but included for certainty.
sub _module_is_unplugged {
my ($module) = @_;
if (Devel::Unplug->can('unplugged')) {
foreach my $unplugged (Devel::Unplug::unplugged()) {
if (ref $unplugged ? $module =~ $unplugged : $module eq $unplugged) {
return 1;
}
}
}
return 0;
}
sub _incval_masks_module {
my ($incval, $module) = @_;
### _incval_masks_module(): $incval, $module
ref $incval or return 0;
if ($incval == \&Test::Without::Module::fake_module) {
if (exists (Test::Without::Module::get_forbidden_list()->{$module})) {
### Test-Without-Module masks ...
return 1;
}
}
require Scalar::Util;
if (Scalar::Util::blessed($incval)
&& $incval->isa('Module::Mask')
&& $incval->is_masked($module)) {
### Module-Mask masks ...
return 1;
}
### not masked ...
return 0;
}
# _pruned_inc($module) using @INC
# _pruned_inc($module, $dir,$dir,...)
# Return list of dirs preceding any mask of $module.
#
sub _pruned_inc {
my $module = shift;
my @inc = @_ ? @_ : @INC;
### _pruned_inc() ...
foreach my $pos (0 .. $#inc) {
if (_incval_masks_module($inc[$pos],$module)) {
$#inc = $pos-1; # truncate
if ($pos == 0) {
return;
}
$#inc = $pos-1;
last;
}
}
### pruned to: @inc
return @inc;
}
{
my $orig = \&Module::Util::find_installed;
sub Module_Util_Masked__find_installed ($;@) {
my $module = shift;
### M-U-Masked find_installed(): $module
if (_module_is_unplugged($module)) {
return undef;
}
my @inc = _pruned_inc($module, @_)
or return undef; # nothing after pruned
### @inc
return &$orig($module,@inc);
}
no warnings 'redefine';
*Module::Util::find_installed = \&Module_Util_Masked__find_installed;
}
{
my $orig = \&Module::Util::all_installed;
sub Module_Util_Masked__all_installed ($;@) {
my $module = shift;
### M-U-Masked all_installed(): $module
if (_module_is_unplugged($module)) {
return;
}
my @inc = _pruned_inc($module, @_)
or return; # nothing after pruned
return &$orig($module,_pruned_inc($module, @_));
}
no warnings 'redefine';
*Module::Util::all_installed = \&Module_Util_Masked__all_installed;
}
{
my $orig = \&Module::Util::find_in_namespace;
sub Module_Util_Masked__find_in_namespace ($;@) {
my $namespace = shift;
### M-U-Masked find_in_namespace(): $namespace
my @masks;
my @ret;
foreach my $incval (@_ ? @_ : @INC) {
if (ref $incval
&& do {
require Scalar::Util;
(Scalar::Util::refaddr($incval)
== \&Test::Without::Module::fake_module
|| (Scalar::Util::blessed($incval)
&& $incval->isa('Module::Mask')))
}) {
push @masks, $incval;
} else {
my @found = &$orig($namespace, $incval);
@found = grep {! _module_is_unplugged($_)} @found;
foreach my $mask (@masks) {
@found = grep {! _incval_masks_module($mask,$_)} @found;
}
push @ret, @found;
}
}
### ret inc duplicates: @ret
my %seen;
return grep { !$seen{$_}++ } @ret;
}
no warnings 'redefine';
*Module::Util::find_in_namespace = \&Module_Util_Masked__find_in_namespace;
}
1;
__END__
# sub _module_is_masked {
# my ($module) = @_;
# ### _module_is_masked(): $module
#
# if (Test::Without::Module->can('get_forbidden_list')) {
# my $href = Test::Without::Module::get_forbidden_list();
# if (exists $href->{$module}) {
# ### no, Test-Without-Module forbidden
# return 0;
# }
# }
#
# require Scalar::Util;
# foreach my $inc (@INC) {
# if (Scalar::Util::blessed($inc)
# && $inc->isa('Module::Mask')
# && $inc->is_masked($module)) {
# ### no, Module-Mask masked
# return 0;
# }
# }
# return 0;
# }
=for stopwords Ryde Test-VariousBits recognise recognised unmangled coderef
=head1 NAME
Module::Util::Masked - mangle Module::Util to recognise module masking
=head1 SYNOPSIS
perl -MModule::Util::Masked \
-MTest::Without::Module=Some::Thing \
myprog.pl ...
perl -MModule::Util::Masked \
-MModule::Mask::Deps \
myprog.pl ...
# or within a script
use Module::Util::Masked;
use Module::Mask;
my $mask = Module::Mask->new ('Some::Thing');
=head1 DESCRIPTION
This module mangles L<Module::Util> functions
find_installed()
all_installed()
find_in_namespace()
to have them not return modules which are "masked" by any of
Module::Mask
Module::Mask::Deps
Test::Without::Module
Devel::Unplug
This is meant for testing, just as these masking modules are meant for
testing, to pretend some modules are not available. Making the "find"
functions in C<Module::Util> reflect the masking helps code which checks
module availability by a find rather than just C<eval{require...}> or
similar.
=head2 Load Order
C<Module::Util::Masked> should be loaded before anything which might import
the C<Module::Util> functions, so the import doesn't grab the original
unmangled functions.
Usually this means loading C<Module::Util::Masked> first, or early enough,
but there's no attempt to detect or enforce that currently. A C<-M> on the
command line is good
perl -MModule::Util::Masked myprog.pl ...
Or for the C<ExtUtils::MakeMaker> harness the same in the usual
C<HARNESS_PERL_SWITCHES> environment variable,
HARNESS_PERL_SWITCHES="-MModule::Util::Masked" make test
Otherwise somewhere near the start of a script
use Module::Util::Masked;
Nothing actually changes in the C<Module::Util> behaviour one of the above
mask modules such as C<Test::Without::Module> is loaded and is asked to mask
some modules. Then the mangled C<Module::Util> will report such modules not
found.
The mangling cannot be undone, but usually there's no need to. If some
modules should be made visible again then ask the masking in
C<Test::Without::Module> or whichever to unmask them.
=head2 Implementation
C<Module::Mask> is recognised by the object it adds to C<@INC>.
C<Module::Mask::Deps> is a subclass of C<Module::Mask> and is recognised the
same way.
C<Test::Without::Module> is recognised by the C<fake_module()> coderef it
adds to C<@INC> (which is not documented as such, so is dependent on the
C<Test::Without::Module> implementation).
The masking object or coderef in C<@INC> is applied at the point it appears
in the C<@INC> list. This means any directory in C<@INC> before the mask is
unaffected, the same way it's unaffected for a C<require> etc. The masking
modules normally put themselves at the start of C<@INC> and are therefore
usually meant to act on everything.
C<Devel::Unplug> is checked by its C<unplugged()> list, when that function
exists. It applies to any C<require> so not to a particular place in
C<@INC>. Should an unplug be enforced when C<find_installed()> etc is given
a path, or only the default C<@INC>? If a path is C<@INC> plus or minus a
few directories and then unplugging would be desirable, but if it's
something unrelated then maybe not.
=head1 SEE ALSO
L<Module::Util>,
L<Module::Mask>,
L<Module::Mask::Deps>,
L<Test::Without::Module>,
L<Devel::Unplug>
=head1 HOME PAGE
L<http://user42.tuxfamily.org/test-variousbits/index.html>
=head1 COPYRIGHT
Copyright 2010, 2011, 2012, 2015 Kevin Ryde
Test-VariousBits is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as published
by the Free Software Foundation; either version 3, or (at your option) any
later version.
Test-VariousBits is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
Public License for more details.
You should have received a copy of the GNU General Public License along
with Test-VariousBits. If not, see L<http://www.gnu.org/licenses/>.
=cut