File Coverage

blib/lib/Devel/Hide.pm

Criterion	Covered	Total	%
statement	99	103	96.1
branch	37	42	88.1
condition	10	12	83.3
subroutine	23	24	95.8
pod			n/a
total	169	181	93.3

package Devel::Hide;

use 5.006001;
use strict;
use warnings;

our $VERSION = '0.0014';

# blech! package variables
#
# @HIDDEN is one of the ways to populate the global hidden list
# $phase is used to identify which version of the hints hash to
#   use - either %^H when we're updating it, or pulling it out
#   of caller() when we want to read it
use vars qw( @HIDDEN $phase );
BEGIN { $phase = 'runtime'; }

# settings are a comma- (and only comma, no quotes or spaces)
# -separated list of key,value,key,value,... There is no
# attempt to support data containing commas.
#
# The list of hidden modules is a comma (and *only* comma,
# no white space, no quotes) separated list of module
# names.
#
# yes, this is a ridiculous way of storing data. It is,
# however, compatible with what we're going to have to
# store in the hints hash for lexical hiding, as that
# only supports string data.
my %GLOBAL_SETTINGS;
_set_setting('global', children => 0);
_set_setting('global', verbose  =>
  defined $ENV{DEVEL_HIDE_VERBOSE}
    ? $ENV{DEVEL_HIDE_VERBOSE}
    : 1
);

# convert a mixed list of modules and filenames to a list of
# filenames
sub _as_filenames {
    return map { /^(\w+::)*\w+$/
        ? do { my $f = "$_.pm"; $f =~ s|::|/|g; $f }
        : $_
    } @_;
}

# Pushes a list to the set of hidden modules/filenames
# warns about the modules which could not be hidden (always)
# and about the ones that were successfully hidden (if verbose)
#
# It works as a batch producing warning messages
# at each invocation (when appropriate).
#
# the first arg is a reference to the config hash to use,
# either global or lexical
sub _push_hidden {
    my $config = shift;

    return unless @_;

    my @too_late;
    for ( _as_filenames(@_) ) {
        if ( $INC{$_} ) {
            push @too_late, $_;
        }
        else {
            $config->{'Devel::Hide/hidden'} =
              $config->{'Devel::Hide/hidden'}
                ? join(',', $config->{'Devel::Hide/hidden'}, $_)
                : $_;
        }
    }
    if ( @too_late ) {
        warn __PACKAGE__, ': Too late to hide ', join( ', ', @too_late ), "\n";
    }
    if ( _get_setting('verbose') && $config->{'Devel::Hide/hidden'}) {
        no warnings 'uninitialized';
        warn __PACKAGE__ . ' hides ' .
            join(
                ', ',
                sort split(
                    /,/, $config->{'Devel::Hide/hidden'}
                )
            ) . "\n";
    }
}

sub _dont_load {
    my $filename = shift;
    my $hidden_by = _get_setting('verbose')
        ? 'hidden'
        : 'hidden by ' . __PACKAGE__;
    die "Can't locate $filename in \@INC ($hidden_by)\n";
}

=begin private

=item B<_core_modules>

    @core = _core_modules($perl_version);

Returns the list of core modules according to
Module::CoreList.

!!! UNUSED BY NOW

It is aimed to expand the tag ':core' into all core
modules in the current version of Perl ($]).
Requires Module::CoreList.

=end private

=cut

sub _core_modules {
    require Module::CoreList;    # XXX require 2.05 or newer
    return Module::CoreList->find_modules( qr/.*/, shift );
}

# _append_to_perl5opt(@to_be_hidden)
sub _append_to_perl5opt {

    $ENV{PERL5OPT} = join( ' ',
        defined($ENV{PERL5OPT}) ? $ENV{PERL5OPT} : (),
        '-MDevel::Hide=' . join(',', @_)
    );

}

sub _is_hidden {
    no warnings 'uninitialized';
    my $module = shift;

    +{
        map { $_ => 1 }
        map {
            split(',', _get_config_ref($_)->{'Devel::Hide/hidden'})
        } qw(global lexical)
    }->{$module};
}

sub _get_setting {
    my $name = shift;
    _exists_setting('lexical', $name)
        ? _get_setting_from('lexical', $name)
        : _get_setting_from('global',  $name)
}

sub _get_setting_from {
    my($source, $name) = @_;

    my $config = _get_config_ref($source);
    _setting_hashref($config)->{$name};
}

sub _exists_setting {
    my($source, $name) = @_;

    my $config = _get_config_ref($source);
    exists(_setting_hashref($config)->{$name});
}

sub _set_setting {
    my($source, $name, $value) = @_;

    my $config = _get_config_ref($source);
    my %hash = (
        %{_setting_hashref($config)},
        $name => $value
    );
    _get_config_ref($source)
      ->{'Devel::Hide/settings'} = join(',', %hash);
}

sub _setting_hashref {
    my $settings = shift->{'Devel::Hide/settings'};
    no warnings 'uninitialized';
    +{ split(/,/, $settings) };
}

sub _get_config_ref {
    my $type = shift;
    if($type eq 'lexical') {
        if($phase eq 'compile') {
            return \%^H;
        } else {
            my $depth = 1;
            while(my @fields = caller($depth)) {
                my $hints_hash = $fields[10];
                if($hints_hash && grep { /^Devel::Hide\// } keys %{$hints_hash}) {
                    # return a copy
                    return { %{$hints_hash} };
                }
                $depth++;
            }
            return {};
        }
    } else {
        return \%GLOBAL_SETTINGS;
    }
}

sub import {
    shift;
    my $which_config = 'global';
    local $phase = 'compile';
    while(@_ && $_[0] =~ /^-/) {
        if( $_[0] eq '-lexically' ) {
            $which_config = 'lexical';
            if($] < 5.010) {
                die("Can't 'use Devel::Hide qw(-lexically ...)' on perl 5.8 and below\n");
            }
        } elsif( $_[0] eq '-from:children' ) {
            _set_setting($which_config, children => 1);
        } elsif( $_[0] eq '-quiet' ) {
            _set_setting($which_config, verbose  => 0);
        } else {
            die("Devel::Hide: don't recognize $_[0]\n");
        }
        shift;
    }
    if (@_) {
        _push_hidden(
            _get_config_ref($which_config),
            @_
        );
        if (_get_setting('children')) {
            _append_to_perl5opt(
                (_get_setting('verbose') ? () : '-quiet'),
                @_
            );
        }
    }
}

# $ENV{DEVEL_HIDE_PM} is split in ' '
# as well as @HIDDEN it accepts Module::Module as well as File/Names.pm
BEGIN {
    # unless @HIDDEN was user-defined elsewhere, set default
    if ( !@HIDDEN && $ENV{DEVEL_HIDE_PM} ) {
        # NOTE. "split ' ', $s" is special. Read "perldoc -f split".
        _push_hidden(
            _get_config_ref('global'),
            split q{ }, $ENV{DEVEL_HIDE_PM}
        );
    }
    else {
        _push_hidden(
            _get_config_ref('global'),
            @HIDDEN
        );
    }
}

sub _inc_hook {
    my ( $coderef, $filename ) = @_;
    if ( _is_hidden($filename) ) { _dont_load($filename); }
     else { return undef; }
}

use lib ( \&_inc_hook );

# TO DO:
# * write unimport() sub
# * write decent docs
# * refactor private function names
# * RT #25528

=begin private

perl -MDevel::Hide=!:core -e script.pl # hide all non-core modules
perl -MDevel::Hide=M,!N -e script.pl  # hide all modules but N plus M

how to implement

%GLOBAL_SETTINGS
%IS_EXCEPTION       if there is an exception, all but the set of exceptions are to be hidden
                           plus the set of hidden modules

          :core(5.8)
          :core      synonym to    :core($])


=end private

=cut

1;

__END__