File Coverage

blib/lib/Env/Export.pm

Criterion	Covered	Total	%
statement	91	91	100.0
branch	38	38	100.0
condition	6	6	100.0
subroutine	13	13	100.0
pod			n/a
total	148	148	100.0

###############################################################################
#
# This file copyright (c) 2009-2011 by Randy J. Ray, all rights reserved
#
# Copying and distribution are permitted under the terms of the Artistic
# License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or
# the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php).
#
###############################################################################
#
#   Description:    Export environment variables as constant subs
#
#   Functions:      import
#
#   Environment:    Umm, yeah... that's kind of the point of it all...
#
###############################################################################

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,
                              prefix   => $prefix,
                              override => $override,
                              link     => $link,
                              split    => $split, };
            }
        }
        # Shell style (* => .*, ? => ., ?* => .+):
        elsif ($pat =~ /[*?]/)
        {
            # Change the shell-style globbing patterns to regex equivalents
            $pat =~ s/[?][*]/.+/g;
            $pat =~ s/[*]/.*/g;
            $pat =~ s/[?]/./g;
            $pat = qr/^$pat$/;

            # Add an entry to @subs for each matching key
            for (grep { $_ =~ $pat } @choices)
            {
                push @subs, { key      => $_,
                              warn     => $warn,
                              prefix   => $prefix,
                              override => $override,
                              link     => $link,
                              split    => $split, };
            }
        }
        # Lastly, acceptable strings:
        elsif ($pat =~ /^[A-Za-z_]\w*$/)
        {
            # Just add a single entry to @subs for the string
            push @subs, { key      => $pat,
                          warn     => $warn,
                          prefix   => $prefix,
                          override => $override,
                          link     => $link,
                          split    => $split, };
        }
        # And if we got here it was almost certainly a pattern that would not
        # be a valid Perl subname. Note that this is not suppressed by :nowarn.
        else
        {
            carp "$me: Unrecognized pattern or keyword '$pat', skipped";
        }

        # Since :split is defined to apply to only the next name or pattern,
        # we have to clear it every iteration just to be safe...
        $split = q{};
    }

    foreach (@subs)
    {
        my $subname = "$_->{prefix}$_->{key}";
        my $envkey  = $_->{key};

        if (exists($callersym->{$subname}) &&
            defined(&{$callersym->{$subname}}) &&
            ! $_->{override})
        {
            # We don't overwrite existing subroutines unless they OK'd it
            # with :override
            if ($_->{warn})
            {
                carp "$me: Will not redefine ${calling_pkg}::$subname, " .
                    'skipping';
            }
            next;
        }

        $subname = "${calling_pkg}::$subname";

        # This may look like a great candidate for a lookup-table of code
        # blocks to eval, but I'd actually prefer to avoid that as it would
        # also require multiple substitutions each iteration as well...
        if ($_->{link})
        {
            if ($_->{split})
            {
                my $localsplit = $_->{split};
                *{$subname} = sub () {
                    return split $localsplit, $ENV{$envkey};
                };
            }
            else
            {
                *{$subname} = sub () {
                    return $ENV{$envkey};
                };
            }
        }
        else
        {
            if ($_->{split})
            {
                my @value = split $_->{split}, $ENV{$envkey};
                *{$subname} = sub () {
                    return @value;
                };
            }
            else
            {
                my $value = $ENV{$envkey};
                *{$subname} = sub () {
                    return $value;
                };
            }
        }
    }

    return;
}

1;

__END__