view release on metacpan or  search on metacpan

lib/Env/Export.pm  view on Meta::CPAN

###############################################################################

package Env::Export;

use 5.006001;
use strict;
use warnings;
use vars qw($VERSION);
use subs qw(import);

use Carp qw(croak carp);

$VERSION = '0.22';
$VERSION = eval $VERSION; ## no critic(ProhibitStringyEval)

###############################################################################
#
#   Sub Name:       import
#
#   Description:    Do the actual import work, namespace wrangling, etc.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $class    in      scalar    Class we're called in
#                   @patterns in      list      One or more patterns or
#                                                 keywords used to select %ENV
#                                                 keys to export
#
#   Environment:    Yeah
#
#   Returns:        void
#
###############################################################################
sub import ## no critic(ProhibitExcessComplexity)
{
    my ($class, @patterns) = @_;
    my $me = "${class}::import";

    ## no critic(ProhibitNoStrict)
    ## no critic(ProhibitProlongedStrictureOverride)
    ## no critic(ProhibitNoWarnings)
    no strict 'refs';
    no warnings qw(redefine prototype);

    if (! @patterns)
    {
        return; # Nothing to do if they didn't request anything
    }

    my ($calling_pkg) = caller;
    my $callersym = \%{"${calling_pkg}::"};

    # Values that are tweaked by keywords that may appear in the @patterns
    # stream:
    my $warn     = 1;
    my $link     = 0;
    my $prefix   = q{};
    my $override = 0;
    my $split    = q{};

    # Establish the set of allowable %ENV keys that are eligible for export.
    # This will avoid repeated iterations over %ENV later, and will remove
    # any keys that could not be used to create valid sub names
    my @choices = grep { /^[A-Za-z_]\w*$/ } keys %ENV;
    # This list will accumulate the set of subs to be created, in the form of
    # metadata:
    my @subs = ();

    while (my $pat = shift @patterns)
    {
        # This would be a lot cleaner if I could assume the presence of the
        # "switch" statement. But I'm not ready to limit this code to 5.10+

        # Because ":split" only applies to the very next argument after it,
        # we have to handle it specially. It gets cleared at the end of every
        # iteration of this loop, so if it is here, peel off the next argument
        # then re-assign $pat to the one after that.
        if ($pat eq ':split')
        {
            $split = shift @patterns;
            $pat   = shift @patterns;
        }

        # Do the keywords first, in most cases they just flip flags back and
        # forth
        if ($pat =~ /^:(no)?warn$/) ## no critic(ProhibitCascadingIfElse)
        {
            $warn = $1 ? 0 : 1;
        }
        elsif ($pat =~ /^:(no)?prefix$/)
        {
            $prefix = $1 ? q{} : shift @patterns;
        }
        elsif ($pat =~ /^:(no)?override$/)
        {
            $override = $1 ? 0 : 1;
        }
        elsif ($pat =~ /^:(no)?link$/)
        {
            $link = $1 ? 0 : 1;
        }
        elsif ($pat eq ':all')
        {
            for (@choices)
            {
                push @subs, { key      => $_,
                              warn     => $warn,
                              prefix   => $prefix,
                              override => $override,
                              link     => $link,
                              split    => $split, };
            }
        }
        # Now handle explicit names, shell-style patterns and regexen:
        # Pre-compiled Perl regexen:
        elsif (ref($pat) eq 'Regexp')
        {
            # Add an entry to @subs for each matching key
            for (grep { $_ =~ $pat } @choices)
            {
                push @subs, { key      => $_,
                              warn     => $warn,