File Coverage

blib/lib/constant/override.pm

Criterion	Covered	Total	%
statement	74	74	100.0
branch	26	26	100.0
condition	3	3	100.0
subroutine	16	16	100.0
pod			n/a
total	119	119	100.0

package constant::override;

use warnings;
use strict;

use Sub::Uplevel;

use Carp;
use constant;

our $VERSION = '0.01';

my $has_been_called = 0; ## no critic

sub _substituted_import
{
    my ($original_import, $default_functionality, $substitute,
        $ignore, $substitute_fn, $class, @args) = @_;

    if (not @args) {
        return;
    }

    my $pkg = caller(1);

    my $multiple = ref $args[0];
    if ($multiple and ref $args[0] ne 'HASH') {
        croak("Invalid reference type '".$multiple."' ".
                "(must be 'HASH').");
    }

    my %constants;
    if ($multiple) {
        %constants = %{$args[0]};
    }
    else {
        $constants{$args[0]} = undef;
    }

    for my $name (keys %constants) {
        my $full_name = $pkg.'::'.$name;

        if (exists $substitute->{$full_name}) {
            $substitute_fn->($full_name, $substitute->{$full_name});
        }
        elsif (exists $substitute->{$name}) {
            $substitute_fn->($full_name, $substitute->{$name});
        }
        elsif (exists $ignore->{$full_name}) {
            next;
        }
        elsif (exists $ignore->{$name}) {
            next;
        }
        elsif ($default_functionality) {
            my @values =
                ($multiple)
                    ? $constants{$name}
                    : @args[1..$#args];
            $substitute_fn->($full_name, @values);
        }
        else {
            uplevel 2, $original_import, ($class, @args);
        }
    }
}

sub import
{
    my $class = shift;
    my %args  = @_;

    my ($ignore, $substitute) = @args{qw(ignore substitute)};

    my %ignore     = map { $_ => 1 } @{$args{'ignore'} || []};
    my %substitute = %{$args{'substitute'} || {}};

    my $value_to_fn = sub {
        my (@values) = @_;
        (@values == 1)
            ? (ref $values[0] eq 'CODE')
                ? $values[0]
                : sub () { $values[0] }
            : sub () { @values }
    };
    my $substitute_fn = sub {
        my ($binding, @values) = @_;
        no warnings;
        no strict 'refs';   ## no critic
        *{$binding} = $value_to_fn->(@values);
    };

    my $default_functionality = (not $has_been_called);
    $has_been_called = 1;

    ## no critic

    no warnings;
    no strict 'refs';

    my $original_import = \&{'constant::import'};
    *{'constant::import'} = sub {
        _substituted_import($original_import,
                            $default_functionality,
                            \%substitute,
                            \%ignore, $substitute_fn, @_)
    };

    return 1;
}

1;

__END__