File Coverage

blib/lib/Perl6/Export.pm

Criterion	Covered	Total	%
statement	14	14	100.0
branch	2	2	100.0
condition			n/a
subroutine	4	4	100.0
pod	0	2	0.0
total	20	22	90.9

package Perl6::Export;
our $VERSION = '0.009';

my $ident   = qr{ [^\W\d] \w* }x;
my $arg     = qr{ : $ident \s* ,? \s* }x;
my $args    = qr{ \s* \( $arg* \) | (?# NOTHING) }x;
my $defargs = qr{ \s* \( $arg* :DEFAULT $arg* \) }x;
my $proto   = qr{ \s* (?: \( [^)]* \) | (?# NOTHING) ) }x;

sub add_to {
    my ($EXPORT, $symbol, $args, $decl) = @_;
    $args = "()" unless $args =~ /\S/;
    $args =~ tr/://d;
    return  q[BEGIN{no strict 'refs';]
         .  q[use vars qw(@EXPORT @EXPORT_OK %EXPORT %EXPORT_TAGS );]
         . qq[push\@$EXPORT,'$symbol';\$EXPORT{'$symbol'}=1;]
         . qq[push\@{\$EXPORT_TAGS\{\$_}},'$symbol' for ('ALL',qw$args)}$decl];
}

sub false_import_sub {
    my $import_sub = q{
        use base 'Exporter';
        use vars qw(@EXPORT @EXPORT_OK %EXPORT %EXPORT_TAGS );
        sub import {
            my @exports;
            for (my $i=1; $i<@_; $i++) {
                for ($_[$i]) {
                    if (!ref && /^[:\$&%\@]?(\w+)$/ &&
                        ( exists $EXPORT{$1} || exists $EXPORT_TAGS{$1}) ) {
                        push @exports, splice @_, $i, 1;
                        $i--;
                    }
                }
            }
            @exports = ":DEFAULT" unless @exports;
            __PACKAGE__->export_to_level(1, $_[0], ':MANDATORY', @exports);
            goto &REAL_IMPORT;
        }
    };
    $import_sub =~ s/\n/ /g;
    $import_sub =~ s/REAL_IMPORT/$_[0]/g;
    return $import_sub;
}

my $MANDATORY = q[BEGIN{$EXPORT_TAGS{MANDATORY}||=[]}];

use Filter::Simple;
use Digest::MD5 'md5_hex';

FILTER {
    return unless /\S/;
    my $real_import_name = '_import_'.md5_hex($_);
    my $false_import_sub = false_import_sub($real_import_name);
    my $real_import_sub = "";
    s/ \b sub \s+ import \s* ([({]) /sub $real_import_name$1/x
        or s/ IMPORT \s* ([{]) /sub $real_import_name$1/x
        or $real_import_sub = "sub $real_import_name {}";
    s{( \b sub \s+ ($ident) $proto) \s+ is \s+ export ($defargs) }
     { add_to('EXPORT',$2,$3,$1) }gex;
    s{( \b our \s+ ([\$\@\%]$ident) $proto) \s+ is \s+ exported ($defargs) }
     { add_to('EXPORT',$2,$3,$1) }gex;
    s{( \b sub \s+ ($ident) $proto ) \s+ is \s+ export ($args) }
     { add_to('EXPORT_OK',$2,$3,$1) }gex;
    s{( \b our \s+ ([\$\@\%]$ident) ) \s+ is \s+ export ($args) }
     { add_to('EXPORT_OK',$2,$3,$1) }gex;
    $_ = $real_import_sub . $false_import_sub . $MANDATORY . $_;
}

__END__