File Coverage

blib/lib/Exporter/NoWork.pm

Criterion	Covered	Total	%
statement	115	117	98.2
branch	48	50	96.0
condition	19	21	90.4
subroutine	11	11	100.0
pod	0	1	0.0
total	193	200	96.5

package Exporter::NoWork;

use 5.006;
use strict;
use warnings;

use Carp;
use Attribute::Handlers;

our $VERSION = '0.03';

my %Config;

sub import {
    my $from = shift;
    my $to   = caller;

    no strict 'refs';
    no warnings 'uninitialized';

    if ($from eq __PACKAGE__) {

        # ->isa fails on 5.6, don't know why
        my $doneISA = $] < 5.008
            ? grep $_ eq __PACKAGE__, @{"$to\::ISA"}
            : $to->isa(__PACKAGE__);

        push @{"$to\::ISA"}, __PACKAGE__ unless $doneISA;

        for (@_) {
            /^-MAGIC$/ and do {
                $Config{$to}{uc} = 'magic';
                next;
            };
            /^-CONSTS$/ and do {
                $Config{$to}{uc} = 'consts';
                next;
            };
            push @{$Config{$to}{default}}, $_;
        }
        return;
    }

    unless ($Config{$from}{grovelled}) {
        for (keys %{"$from\::"}) {

            if (exists &{"$from\::$_"}
                and not /^(?:IMPORT|CONFIG)$/
                and not /^_/
                and not ($Config{$from}{uc} eq 'magic' and /^[[:upper:]]+$/)
            ){
                if ($Config{$from}{uc} eq 'consts'
                    and /^[[:upper:]_\d]+$/
                ) {
                    push @{$Config{$from}{default}}, $_;
                    push @{$Config{$from}{consts}},  $_;
                }

                push @{$Config{$from}{all}}, $_;
            }
        }
        $Config{$from}{grovelled} = 1;
    }

    @_ or @_ = @{$Config{$from}{default}};

    $from->can('IMPORT') and @_ = $from->IMPORT(@_);

    my @todo;

    SUB:
    while (my $sub = shift) {

        # we have to do it like this, as C doesn't work
        for ($sub) {
            /^import$/i | /^CONFIG$/ and do {
                croak "Import methods can't be imported";
                next SUB;
            };

            s/^:// and do {
                /^ALL$/ and do {
                    push @_, @{$Config{$from}{all}};
                    next SUB;
                };
                /^DEFAULT$/ and do {
                    push @_, @{$Config{$from}{default}};
                    next SUB;
                };
                /^CONSTS$/ and do {
                    push @_, @{$Config{$from}{consts}};
                    next SUB;
                };

                if ($Config{$from}{tags}{$_}) {
                    push @todo, @{$Config{$from}{tags}{$_}};
                }
                else {
                    croak qq{Tag ":$_" is not recognized by $from};
                }
                next SUB;
            };

            s/^-// and do {
                if (${"$from\::CONFIG"}{$_}) {
                    ${"$from\::CONFIG"}{$_}->($from, $_, \@_);
                }
                elsif ($from->can('CONFIG')) {
                    $from->CONFIG($_, \@_);
                }
                else {
                    croak qq{Config option "-$_" is not recognized by $from};
                }
                next SUB;
            };

            s/^\&//;
            /\W/ || /^_/ and croak qq{"$_" is not exported by $from};

            {
                no warnings 'uninitialized';
                /^[[:upper:]]+$/ and $Config{$from}{uc} eq 'magic'
                    and croak qq{Magic methods can't be exported};
            }
        }

        if (exists &{"$from\::$sub"}) {
            #carp "copying \&$from\::$sub into $to";
            *{"$to\::$sub"} = \&{"$from\::$sub"};
            next SUB;
        }

        croak qq{"$sub" is not exported by $from};
    }

    for (keys %{"$from\::"}) {
        for my $ref (@todo) {
            defined &{"$from\::$_"} or next;
            #carp "ref-ifying \&$from\::$_";
            if ($ref == \&{"$from\::$_"}) {
                *{"$to\::$_"} = $ref;
            }
        }
    }
}

sub Tag : ATTR(CODE,BEGIN) {
    my ($pkg, undef, $ref, undef, $tag, undef) = @_;

    ref $tag or $tag = [$tag];
    for (@$tag) {
        push @{$Config{$pkg}{tags}{$_}}, $ref;
    }
}

1;

__END__