File Coverage

blib/lib/Module/Util/Masked.pm

Criterion	Covered	Total	%
statement	63	71	88.7
branch	21	34	61.7
condition	10	15	66.6
subroutine	12	12	100.0
pod	0	3	0.0
total	106	135	78.5

# Copyright 2010, 2011, 2012, 2015, 2017 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 .

package Module::Util::Masked;
require 5;
use strict;

use vars qw($VERSION);
$VERSION = 8;

# 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) {
    ### incval is Test-Without-Module fake_module ...
    my $href = Test::Without::Module::get_forbidden_list();
    ### $href

    # Test::Without::Module 0.18 and earlier had Foo::Bar module name
    # Test::Without::Module 0.20 has Foo/Bar.pm path
    # look for either
    if (exists $href->{$module}
       || exists $href->{Module::Util::module_path($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__