File Coverage

blib/lib/Test/Stream/Exporter.pm

Criterion	Covered	Total	%
statement	95	95	100.0
branch	37	38	97.3
condition	17	18	94.4
subroutine	17	17	100.0
pod	5	5	100.0
total	171	173	98.8

package Test::Stream::Exporter;
use strict;
use warnings;

use Test::Stream::Exporter::Meta();

use Scalar::Util qw/reftype/;

use Carp qw/croak confess/;

BEGIN { Test::Stream::Exporter::Meta->new(__PACKAGE__) };

sub import {
    my $class = shift;
    my $caller = caller;

    Test::Stream::Exporter::Meta->new($caller);
    export_from($class => $caller, \@_);
}

sub unimport {
    my ($class, @list) = @_;
    my $pkg = caller;

    @list = qw/export exports default_export default_exports export_from/ unless @list;

    for my $name (@list) {
        my $ref = $pkg->can($name) || next;
        no strict 'refs';
        next unless $ref == \&{$name};
        local *GLOBCLONE = *{"$pkg\::$name"};
        my $stash = \%{"${pkg}\::"};
        delete $stash->{$name};
        for my $slot (qw/HASH SCALAR ARRAY IO FORMAT/) {
            *{"$pkg\::$name"} = *GLOBCLONE{$slot} if defined *GLOBCLONE{$slot};
        }
    }
}

###############
# Exported Methods
###############

exports(qw/export_to/);

default_export( import => sub {
    return unless Test::Stream::Exporter::Meta::get($_[0]);
    my $class = shift;
    my $caller = caller;
    export_from($class => $caller, \@_);
});

sub export_to {
    my ($from, $dest, $args) = @_;

    my $meta = Test::Stream::Exporter::Meta->new($from);
    my $exports = $meta->exports;

    my @imports;
    my %exclude;
    if ($args && @$args) {
        my %seen;
        my $all = 0;
        my $def = 0;
        for my $item (@$args) {
            # Keep track of what we have seen so that things do not get
            # re-added by '-all'. We do not want to skip things already seen
            # here though as people may alias a single sub to multiple names.
            $seen{$item}++;
            if (!ref($item) && $item =~ m/^-(all|default)$/) {
                my $tag = $1;
                $all++ if $tag eq 'all';
                $def++ if $tag eq 'default';
            }
            elsif ($item =~ m/^!(.*)$/) {
                $exclude{$1}++;
            }
            else {
                push @imports => $item;
            }
        }
        push @imports => grep { !$seen{$_}++ } @{$meta->default} if $def;
        push @imports => grep { !$seen{$_}++ } keys %$exports    if $all;
    }
    else {
        @imports = @{$meta->default};
    }

    while (my $export = shift @imports) {
        my $ref = $exports->{$export}
            or croak qq{"$export" is not exported by the $from module};

        my $name = $export;
        if (@imports && ref $imports[0]) {
            my $options = shift @imports;
            croak "import options must be specified as a hashref, got '$options'"
                unless reftype($options) eq 'HASH';

            my $prefix  = delete $options->{'-prefix'}  || "";
            my $postfix = delete $options->{'-postfix'} || "";
            my $infix   = delete $options->{'-as'}      || $export;

            croak "'$_' is not a valid export option for export '$export'"
                for keys %$options;

            $name = join '' => $prefix, $infix, $postfix;
        }

        next if $exclude{$export};

        no strict 'refs';
        *{"$dest\::$name"} = $ref;
    }
}

###############
# Exported Functions
###############

default_exports(qw/export exports default_export default_exports/);
exports(qw/export_from/);

# There is no implementation difference, but different names make the purpose
# of each use more clear.
BEGIN { *export_from = \&export_to }

sub export {
    my $caller = caller;

    my $meta = Test::Stream::Exporter::Meta::get($caller)
        or confess "$caller is not an exporter!?";

    # Only the first 2 args are used.
    $meta->add(0, @_);
}

sub exports {
    my $caller = caller;

    my $meta = Test::Stream::Exporter::Meta::get($caller)
        or confess "$caller is not an exporter!?";

    $meta->add_bulk(0, @_);
}

sub default_export {
    my $caller = caller;

    my $meta = Test::Stream::Exporter::Meta::get($caller)
        or confess "$caller is not an exporter!?";

    # Only the first 2 args are used.
    $meta->add(1, @_);
}

sub default_exports {
    my $caller = caller;

    my $meta = Test::Stream::Exporter::Meta::get($caller)
        or confess "$caller is not an exporter!?";

    $meta->add_bulk(1, @_);
}

1;

__END__