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.07';

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 qq[BEGIN{no strict 'refs';]
	     . 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';
		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 $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__