File Coverage

blib/lib/Exporter/Attributes.pm

Criterion	Covered	Total	%
statement	43	43	100.0
branch	3	4	75.0
condition	1	2	50.0
subroutine	9	9	100.0
pod	0	1	0.0
total	56	59	94.9

use strict;
use warnings FATAL => 'all';

package Exporter::Attributes;

# ABSTRACT: Export symbols by attributes

use Exporter 5.72 ();
use Attribute::Universal 0.002 Exportable => 'ANY,BEGIN',
  Exported                                => 'ANY,BEGIN';
use Carp qw(croak);

our $VERSION = '0.001';    # VERSION

our @EXPORT_OK = qw(import);

my $symbols = {};

my %lists = (
    Exportable => 'export_ok',
    Exported   => 'export',
);

my %sigil = (
    SCALAR => '$',
    ARRAY  => '@',
    HASH   => '%',
    CODE   => '&',
);

sub add {
    my ( $package, $list, $name, @tags ) = @_;
    $symbols->{$package} //= {
        export      => [],
        export_ok   => [],
        export_tags => {},
    };
    push @{ $symbols->{$package}->{$list} } => $name;
    return unless @tags;
    foreach my $tag (@tags) {
        push @{ $symbols->{$package}->{export_tags}->{$tag} } => $name;
    }
}

use namespace::clean;

sub ATTRIBUTE {
    my $attr = Attribute::Universal::to_hash(@_);
    my ( $package, $symbol, $referent, $attribute, $payload, $phase, $file,
        $line )
      = @_;
    croak("lexical symbols are not exportable, in $file at line $line")
      unless ref $attr->{symbol};
    my $sigil = $sigil{ $attr->{type} };
    my $list  = $lists{ $attr->{attribute} };
    my @tags  = map { split /[\s,]+/ } @{ $attr->{payload} };
    add( $attr->{package}, $list, $sigil . $attr->{label}, @tags );
}

sub import {
    my $class = $_[0];

    # export our own "import" method into the caller class
    # so abort here if "import" is called by "use Exporter::Attributes"
    goto &Exporter::import if $class eq __PACKAGE__;

    # get export symbols or just return
    my $_symbols = $symbols->{$class} // return;

    # build :all export tag by concat @EXPORT and @EXPORT_OK
    $_symbols->{export_tags}->{all} =
      [ @{ $_symbols->{export} }, @{ $_symbols->{export_ok} }, ];

# this is a quite easy way to say "our @Class::EXPORT", which is normally not possible
# we are rewriting the symbol table, dont let strict concern about it!
    no strict 'refs';    ## no critic
    *{"${class}::EXPORT"}      = $_symbols->{export};
    *{"${class}::EXPORT_OK"}   = $_symbols->{export_ok};
    *{"${class}::EXPORT_TAGS"} = $_symbols->{export_tags};

    # and finally let import the symbol into the caller namespace.
    goto &Exporter::import;
}

1;

__END__