File Coverage

blib/lib/Const/Exporter.pm

Criterion	Covered	Total	%
statement	125	128	97.6
branch	31	36	86.1
condition	17	24	70.8
subroutine	16	17	94.1
pod			n/a
total	189	205	92.2

package Const::Exporter;

# ABSTRACT: Declare constants for export.

use v5.10.0;

use strict;
use warnings;

our $VERSION = 'v1.2.1';

use Carp;
use Const::Fast;
use Exporter ();
use List::Util '1.56' => qw/ pairs mesh /;
use Package::Stash;
use Ref::Util qw/ is_blessed_ref is_arrayref is_coderef is_hashref is_ref /;

# RECOMMEND PREREQ: List::SomeUtils::XS
# RECOMMEND PREREQ: Package::Stash::XS
# RECOMMEND PREREQ: Ref::Util::XS
# RECOMMEND PREREQ: Storable

sub import {
    my $pkg = shift;

    strict->import;
    warnings->import;

    my $caller = caller;
    my $stash  = Package::Stash->new($caller);

    # Create @EXPORT, @EXPORT_OK, %EXPORT_TAGS and import if they
    # don't yet exist.

    my $export = $stash->get_or_add_symbol('@EXPORT');

    my $export_ok = $stash->get_or_add_symbol('@EXPORT_OK');

    my $export_tags = $stash->get_or_add_symbol('%EXPORT_TAGS');

    $stash->add_symbol( '&import', \&Exporter::import )
      unless ( $stash->has_symbol('&import') );

    $stash->add_symbol( '&const', \&Const::Fast::const );
    _export_symbol( $stash, 'const' );

    foreach my $set ( pairs @_ ) {

        my $tag = $set->key;
        croak "'${tag}' is reserved" if $tag eq 'all';

        my $defs = $set->value;

        croak "An array reference required for tag '${tag}'"
          unless is_arrayref($defs);

        while ( my $item = shift @{$defs} ) {

            for ($item) {

                # Array reference means a list of enumerated symbols

                if ( is_arrayref($_) ) {

                    my @enums = @{$item};
                    my $start = shift @{$defs};

                    my @values = is_arrayref($start) ? @{$start} : ($start);

                    my $last = $values[0] // 0;
                    my $fn = sub { $_[0] + 1 };

                    if ( is_coderef $values[1] ) {
                        $fn = $values[1];
                        $values[1] = undef;
                    }

                    foreach my $pair ( pairs mesh \@enums, \@values ) {
                        my $value = $pair->value // $fn->($last);
                        $last = $value;
                        my $symbol = $pair->key // next;

                        _add_symbol( $stash, $symbol, $value );
                        _export_symbol( $stash, $symbol, $tag );

                    }

                    next;
                }

                # A scalar is a name of a symbol

                if ( !is_ref($_) ) {

                    my $symbol = $item;
                    my $sigil  = _get_sigil($symbol);
                    my $norm =
                      ( $sigil eq '&' ) ? ( $sigil . $symbol ) : $symbol;

                    # If the symbol is already defined, that we add it
                    # to the exports for that tag and assume no value
                    # is given for it.

                    if ( $stash->has_symbol($norm) ) {

                        my $ref = $stash->get_symbol($norm);

                        # In case symbol is defined as `our`
                        # beforehand, ensure it is readonly.

                        Const::Fast::_make_readonly( $ref => 1 );

                        _export_symbol( $stash, $symbol, $tag );

                        next;

                    }

                    my $value = shift @{$defs};

                    _add_symbol( $stash, $symbol, $value );
                    _export_symbol( $stash, $symbol, $tag );

                    next;
                }

                croak "$_ is not supported";

            }

        }

    }

    # Now ensure @EXPORT, @EXPORT_OK and %EXPORT_TAGS contain unique
    # symbols. This may not matter to Exporter, but we want to ensure
    # the values are 'clean'. It also simplifies testing.

    push @{$export}, @{ $export_tags->{default} } if $export_tags->{default};
    _uniq($export);

    _uniq($export_ok);

    $export_tags->{all} //= [];
    push @{ $export_tags->{all} }, @{$export_ok};

    _uniq( $export_tags->{$_} ) for keys %{$export_tags};

}

# Add a symbol to the stash

sub _check_sigil_against_value {
    my ($sigil, $value) = @_;

    return 1 if $sigil eq '@' && is_arrayref($value);
    return 1 if $sigil eq '%' && is_hashref($value);
    return 1 if $sigil eq '&' && is_coderef($value);
    return 1 if $sigil eq '$';

    return 0;
}

sub _add_symbol {
    my ( $stash, $symbol, $value ) = @_;

    my $sigil = _get_sigil($symbol);
    if ( $sigil ne '&' ) {

        if ( is_blessed_ref $value) {

            $stash->add_symbol( $symbol, \$value );
            Const::Fast::_make_readonly( $stash->get_symbol($symbol) => 1 );

        }
        else {

            croak "Invalid type for $symbol"
                unless _check_sigil_against_value($sigil, $value);

            $stash->add_symbol( $symbol, $value );
            Const::Fast::_make_readonly( $stash->get_symbol($symbol) => 1 );
        }

    }
    else {

        const my $copy => is_coderef($value) ? $value->() : $value;
        $stash->add_symbol( '&' . $symbol, sub() { $copy } );

    }
}

# Add a symbol to @EXPORT_OK and %EXPORT_TAGS

sub _export_symbol {
    my ( $stash, $symbol, $tag ) = @_;

    my $export_ok   = $stash->get_symbol('@EXPORT_OK');
    my $export_tags = $stash->get_symbol('%EXPORT_TAGS');

    $tag //= 'all';

    $export_tags->{$tag} //= [];

    push @{ $export_tags->{$tag} }, $symbol;
    push @{$export_ok}, $symbol;
}

# Function to get the sigil from a symbol. If no sigil, it assumes
# that it is a function reference.

sub _get_sigil {
    my ($symbol) = @_;
    my ($sigil) = $symbol =~ /^(\W)/;
    return $sigil // '&';
}

# Function to take a list reference and prune duplicate elements from
# it.

sub _uniq {
    my ($listref) = @_;
    my %seen;
    while ( my $item = shift @{$listref} ) {
        $seen{$item} = 1;
    }
    push @{$listref}, keys %seen;
}

1;

__END__