File Coverage

blib/lib/ExportAbove.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	26	28	92.8
condition	3	3	100.0
subroutine	8	8	100.0
pod	0	1	0.0
total	108	111	97.3

package ExportAbove;

use strict;
use vars qw($VERSION);

$VERSION = '0.02';

my %Already;

sub import {
	my($class, @args) = @_;
	my $from = caller;
	no strict 'refs';
	for my $sym(keys %{$from."::"}) {
		next if $sym =~ /^[A-Z]+$/;  # neglect BEGIN, AUTOLOAD, ...
		my @expnames;
		if( defined *{$from."::".$sym}{CODE} ) {
			push @expnames, newname($from, $sym);
		}
		if( defined *{$from."::".$sym}{SCALAR} ) {
			push @expnames, newname($from, '$'.$sym);
		}
		if( defined *{$from."::".$sym}{HASH} ) {
			push @expnames, newname($from, '%'.$sym);
		}
		if( defined *{$from."::".$sym}{ARRAY} ) {
			push @expnames, newname($from, '@'.$sym);
		}
		#print "@expnames\n";
		if( @args ) {
			my($taged, $oked) = (0, 0);
			for my $arg(@args) {
				if( $arg eq 'OK' ) {
					push @{$from."::EXPORT_OK"}, @expnames;
					$oked = 1;
				} else {
					$arg =~ s/^://;
					push @{${$from."::EXPORT_TAGS"}{$arg}}, @expnames;
					$taged = 1;
				}
			}
			if( $taged && !$oked) {
				push @{$from."::EXPORT"}, @expnames;
			}
		} else {
			push @{$from."::EXPORT"}, @expnames;
		}
	}
}

sub unimport {
	my $from = caller;
	no strict 'refs';
	for my $sym(keys %{$from."::"}) {
		next if $sym =~ /^[A-Z]+$/;
		if( defined *{$from."::".$sym}{CODE} ) {
			newname($from, $sym);
		}
		if( defined *{$from."::".$sym}{SCALAR} ) {
			newname($from, '$'.$sym);
		}
		if( defined *{$from."::".$sym}{HASH} ) {
			newname($from, '%'.$sym);
		}
		if( defined *{$from."::".$sym}{ARRAY} ) {
			newname($from, '@'.$sym);
		}
	}
}

sub newname {
	my($pkg, $name) = @_;
	if( $Already{$pkg}{$name} ) {
		return ();
	} else {
		$Already{$pkg}{$name}++;
		return ($name);
	}
}

1;
__END__