view release on metacpan or  search on metacpan

lib/Perl6/Export/Attrs.pm  view on Meta::CPAN

 package Perl6::Export::Attrs;

our $VERSION = '0.000006';

use warnings;
use strict;
use Carp;
use Attribute::Handlers;
use PadWalker qw( var_name peek_my );

my %IMPORT_for;

sub import {
    my $caller = caller;
    no strict 'refs';
    *{$caller.'::import'} = \&_generic_import;
    *{$caller.'::IMPORT'} = sub (&) { $IMPORT_for{$caller} = shift };
    for my $var_type (qw( SCALAR ARRAY HASH CODE )) {
        *{$caller.'::MODIFY_'.$var_type.'_ATTRIBUTES'} = \&_generic_handler;
    }
    return;
}

my %tagsets_for;
my %is_exported_from;
my %named_tagsets_for;
my %decl_loc_for;
my %name_of;

my $IDENT = '[^\W\d]\w*';

sub _generic_handler {
    my ($package, $referent, @attrs) = @_;

    ATTR:
    for my $attr (@attrs) {

        ($attr||=q{}) =~ s/\A Export (?: \( (.*) \) )? \z/$1||q{}/exms
            or next ATTR;

        my @tagsets = grep {length $_} split m/ \s+,?\s* | ,\s* /xms, $attr;

        my (undef, $file, $line) = caller(1);
        $file =~ s{.*/}{}xms;

        if (my @bad_tags = grep {!m/\A :$IDENT \z/xms} @tagsets) {
            die 'Bad tagset',
                (@bad_tags==1?' ':'s '),
                "in :Export attribute at '$file' line $line: [@bad_tags]\n";
        }

        my $tagsets = $tagsets_for{$package} ||= {};

        for my $tagset (@tagsets) {
            push @{ $tagsets->{$tagset} }, $referent;
        }
        push @{ $tagsets->{':ALL'} }, $referent;

        $is_exported_from{$package}{$referent} = 1;
        $decl_loc_for{$referent} = "$file line $line";
        $name_of{$referent} = _get_lexical_name($referent);

        undef $attr;

    }

    return grep {defined $_} @attrs;
}

my %desc_for = (
    SCALAR => 'lexical scalar variable',
    ARRAY  => 'lexical array variable',
    HASH   => 'lexical hash variable',
    CODE   => 'anonymous subroutine',
);

my %hint_for = (
    SCALAR => "(declare the variable with 'our' instead of 'my')",
    ARRAY  => "(declare the variable with 'our' instead of 'my')",
    HASH   => "(declare the variable with 'our' instead of 'my')",
    CODE   => "(specify a name after the 'sub' keyword)",
);

sub _get_lexical_name {
    my ($var_ref) = @_;
    return if ref $var_ref eq 'CODE';

    SEARCH:
    for my $up_level (1..(~0>>1)-1) {
        my $sym_tab_ref = eval { peek_my($up_level) }
            or last SEARCH;

        for my $var_name (keys %{$sym_tab_ref}) {
            return $var_name if $var_ref == $sym_tab_ref->{$var_name};
        }
    }
    return;
}

sub _invert_tagset {
    my ($package, $tagset) = @_;