File Coverage

blib/lib/Perl6/Export/Attrs.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

 package Perl6::Export::Attrs;

our $VERSION = '0.000005';

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) = @_;
    my %inverted_tagset;

    for my $tag (keys %{$tagset}) {
        for my $sub_ref (@{$tagset->{$tag}}) {
            my $type = ref $sub_ref;
            my $sym = Attribute::Handlers::findsym($package, $sub_ref, $type)
                   || $name_of{$sub_ref}
                or die "Can't export $desc_for{$type} ",
                       "at $decl_loc_for{$sub_ref}\n$hint_for{$type}\n";
            if (ref $sym) {
                $sym = *{$sym}{NAME};
            }
            $inverted_tagset{$tag}{$sym} = $sub_ref;
        }
    }

    return \%inverted_tagset;
}

my %type_for = qw( $ SCALAR   @ ARRAY   % HASH );

# Reusable import() subroutine for all packages...
sub _generic_import {
    my $package = shift;

    my $tagset
        = $named_tagsets_for{$package}
        ||= _invert_tagset($package, $tagsets_for{$package});

    my $is_exported = $is_exported_from{$package};

    my $errors;

    my %request;
    my $subs_ref;

    my $args_supplied = @_;

    my $argno = 0;
    REQUEST:
    while ($argno < @_) {
        my $request = $_[$argno];
        if (my ($sub_name) = $request =~ m/\A & ($IDENT) (?:\(\))? \z/xms) {
            if (exists $request{$sub_name}) {
                splice @_, $argno, 1;
                next REQUEST;
            }
            no strict 'refs';
            no warnings 'once';
            if (my $sub_ref = *{$package.'::'.$sub_name}{CODE}) {
                if ($is_exported->{$sub_ref}) {
                    $request{$sub_name} = $sub_ref;
                    splice @_, $argno, 1;
                    next REQUEST;
                }
            }
        }
        elsif (my ($sigil, $name) = $request =~ m/\A ([\$\@%])($IDENT) \z/xms) {
            next REQUEST if exists $request{$sigil.$name};
            no strict 'refs';
            no warnings 'once';
            if (my $var_ref = *{$package.'::'.$name}{$type_for{$sigil}}) {
                if ($is_exported->{$var_ref}) {
                    $request{$sigil.$name} = $var_ref;
                    splice @_, $argno, 1;
                    next REQUEST;
                }
            }
        }
        elsif ($request =~ m/\A :$IDENT \z/xms
               and $subs_ref = $tagset->{$request}) {
            @request{keys %{$subs_ref}} = values %{$subs_ref};
            splice @_, $argno, 1;
            next REQUEST;
        }
        $errors .= " $request";
        $argno++;
    }

    # Report unexportable requests...
    my $real_import = $IMPORT_for{$package};

    croak "$package does not export:$errors\nuse $package failed"
        if $errors && !$real_import;

    if (!$args_supplied) {
        %request = %{$tagset->{':DEFAULT'}||={}}
    }

    my $mandatory = $tagset->{':MANDATORY'} ||= {};
    @request{ keys %{$mandatory} } = values %{$mandatory};

    my $caller = caller;

    for my $sub_name (keys %request) {
        no strict 'refs';
        my ($sym_name) = $sub_name =~ m{\A [\$\@&%]? (.*)}xms;
        *{$caller.'::'.$sym_name} = $request{$sub_name};
    }

    if ($real_import) {
        my $idx=0;
        while ($idx < @_) {
            if (defined $_[$idx]) { $idx++             }
            else                  { splice @_, $idx, 1 }
        }
        goto &{$real_import};
    }
    return;
}

1; # Magic true value required at end of module
__END__