File Coverage

blib/lib/lib/filter.pm

Criterion	Covered	Total	%
statement	11	141	7.8
branch	2	106	1.8
condition	0	22	0.0
subroutine	4	11	36.3
pod	0	2	0.0
total	17	282	6.0

package lib::filter;

#use 5.008009;  # the first version where Module::CoreList becomes core
use strict 'subs', 'vars'; # no need to avoid strict & warnings, because Config uses them
use warnings;
use Config;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-08-29'; # DATE
our $DIST = 'lib-filter'; # DIST
our $VERSION = '0.281'; # VERSION

# BEGIN snippet from Module::Path::More, with mods/simplification
my $SEPARATOR;
BEGIN {
    if ($^O =~ /^(dos|os2)/i) {
        $SEPARATOR = '\\';
    } elsif ($^O =~ /^MacOS/i) {
        $SEPARATOR = ':';
    } else {
        $SEPARATOR = '/';
    }
}
sub module_path {
    my ($file, $inc) = @_;

    foreach my $dir (@$inc) {
        next if !defined($dir);
        next if ref($dir);
        my $path = $dir . $SEPARATOR . $file;
        return $path if -f $path;
    }
    undef;
}
# END snippet from Module::Path::More

sub _open_handle {
    my $path = shift;
    open my($fh), "<", $path
        or die "Can't open $path: $!";
    $fh;
}

my $handler;
my $hook;
my ($orig_inc, $orig_inc_sorted_by_len);

sub lib::filter::INC { goto $handler }

sub import {
    my ($class, %opts) = @_;

    my $dbgh = "[lib::filter]";

    for (keys %opts) {
        die "Unknown option $_"
            unless /\A(
                        debug|
                        allow_core|allow_noncore|
                        extra_inc|
                        allow|allow_list|allow_re|
                        allow_is_recursive|
                        disallow|disallow_list|disallow_re|
                        filter
                    )\z/x;
    }

    $opts{debug} = $ENV{PERL_LIB_FILTER_DEBUG} unless defined($opts{debug});

    $opts{allow_core}    = 1 if !defined($opts{allow_core});
    $opts{allow_noncore} = 1 if !defined($opts{allow_noncore});

    if ($opts{filter} && !ref($opts{filter})) {
        # convenience, for when filter is specified from command-line (-M)
        $opts{filter} = eval $opts{filter}; ## no critic: BuiltinFunctions::ProhibitStringyEval
        die "Error in filter code: $@" if $@;
    }

    if ($opts{extra_inc}) {
        unshift @INC, split(/:/, $opts{extra_inc});
    }

    if (!$orig_inc) {
        $orig_inc = [@INC];
        $orig_inc_sorted_by_len = [sort {length($b) <=> length($a)} @INC];
    }

    my $core_inc = [@Config{qw(privlibexp archlibexp)}];
    my $noncore_inc = [grep {$_ ne $Config{privlibexp} &&
                                 $_ ne $Config{archlibexp}} @$orig_inc];
    my %allow;
    if ($opts{allow}) {
        for (split /\s*;\s*/, $opts{allow}) {
            $allow{$_} = "allow";
        }
    }
    if ($opts{allow_list}) {
        open my($fh), "<", $opts{allow_list}
            or die "Can't open allow_list file '$opts{allow_list}': $!";
        while (my $line = <$fh>) {
            $line =~ s/^\s+//;
            $line =~ /^(\w+(?:::\w+)*)/ or next;
            $allow{$1} ||= "allow_list";
        }
    }

    my %disallow;
    if ($opts{disallow}) {
        for (split /\s*;\s*/, $opts{disallow}) {
            $disallow{$_} = "disallow";
            (my $pm = "$_.pm") =~ s!::!/!g; delete $INC{$pm};
        }
    }
    if ($opts{disallow_list}) {
        open my($fh), "<", $opts{disallow_list}
            or die "Can't open disallow_list file '$opts{disallow_list}': $!";
        while (my $line = <$fh>) {
            $line =~ s/^\s+//;
            $line =~ /^(\w+(?:::\w+)*)/ or next;
            $disallow{$1} ||= "disallow_list";
            (my $pm = "$1.pm") =~ s!::!/!g; delete $INC{$pm};
        }
    }

    $handler = sub {
        my ($self, $file) = @_;

        my @caller = caller(0);

        warn "$dbgh hook called for $file (from package $caller[0] file $caller[1])\n" if $opts{debug};

        my $path;
      FILTER:
        {
            my $mod = $file; $mod =~ s/\.pm$//; $mod =~ s!/!::!g;
            my $err_prefix = "Can't locate $file";
            if ($opts{filter}) {
                local $_ = $mod;
                warn "$dbgh Checking against custom filter ...\n" if $opts{debug};
                unless ($opts{filter}->($mod)) {
                    die "$err_prefix (module '$mod' is disallowed (filter))";
                }
            }
            if ($opts{disallow_re} && $mod =~ /$opts{disallow_re}/) {
                die "$err_prefix (module '$mod' is disallowed (disallow_re))";
            }
            if ($disallow{$mod}) {
                die "$err_prefix (module '$mod' is disallowed ($disallow{$mod}))";
            }
            if ($opts{allow_re} && $mod =~ /$opts{allow_re}/) {
                warn "$dbgh module $mod matches allow_re\n" if $opts{debug};
                $path = module_path($file, $orig_inc);
                last FILTER if $path;
                die "$err_prefix (module '$mod' is allowed (allow_re) but can't locate $file in \@INC (\@INC contains: ".join(" ", @INC)."))";
            }
            if ($allow{$mod}) {
                warn "$dbgh module $mod matches $allow{$mod}\n" if $opts{debug};
                $path = module_path($file, $orig_inc);
                last FILTER if $path;
                die "$err_prefix (module '$mod' is allowed ($allow{$mod}) but can't locate $file in \@INC (\@INC contains: ".join(" ", @INC)."))";
            }
            if ($opts{allow_is_recursive}) {
                my $caller_pkg_from_file;
                for (@$orig_inc_sorted_by_len) {
                    #print "D:\$_=<$_> vs $caller[1]\n";
                    if (index($caller[1], $_) == 0) {
                        $caller_pkg_from_file = substr($caller[1], length($_)+1);
                        #print "D:caller_pkg_from_file=<$caller_pkg_from_file>\n";
                        $caller_pkg_from_file =~ s/\.pm\z//;
                        $caller_pkg_from_file =~ s/\Q$Config{archname}\E.//;
                        $caller_pkg_from_file =~ s![/\\]!::!g;
                    }
                }
                for my $caller_pkg (grep {defined} $caller[0], $caller_pkg_from_file) {
                    (my $pm = "$caller_pkg.pm") =~ s!::!/!g;
                    if (exists $INC{$pm}) {
                        $path = module_path($file, $orig_inc);
                        if ($path) {
                            warn "$dbgh module '$mod' allowed because it is require'd by $caller_pkg (allow_is_recursive=1)\n" if $opts{debug};
                            last FILTER;
                        }
                    }
                }
            }

            my $inc;
            if ($opts{allow_noncore} && $opts{allow_core}) {
                $inc = $orig_inc;
            } elsif ($opts{allow_core}) {
                $inc = $core_inc;
            } elsif ($opts{allow_noncore}) {
                $inc = $noncore_inc;
            }
            if ($inc) {
                warn "$dbgh searching $file in (".join(", ", @$inc).")\n" if $opts{debug};
                $path = module_path($file, $inc);
            }
            last FILTER if $path;
        } # FILTER

        unless ($path) {
            warn "$dbgh $file not found\n" if $opts{debug};
            return;
        }

        warn "$dbgh $file found at $path\n" if $opts{debug};
        $INC{$file} = $path;
        return _open_handle($path);
    };
    $hook = bless(sub{"dummy"}, __PACKAGE__);

    @INC = (
        $hook,
        grep {
            my $mod = $_;
            if ("$mod" eq "$hook") {
                0;
            } elsif ($opts{allow_core} && grep {$mod eq $_} @$core_inc) {
                1;
            } elsif ($opts{allow_noncore} && grep {$mod eq $_} @$noncore_inc) {
                1;
            } else {
                0;
            }
        } @$orig_inc,
    );
    #use DD; dd $orig_inc;
    #use DD; dd \@INC;
}

sub unimport {
    return unless $hook;
    @INC = grep { "$_" ne "$hook" } @INC;
}

1;
# ABSTRACT: Allow/disallow loading modules

__END__