File Coverage

blib/lib/Exporter/Easy.pm

Criterion	Covered	Total	%
statement	116	121	95.8
branch	62	80	77.5
condition	7	11	63.6
subroutine	10	10	100.0
pod	0	4	0.0
total	195	226	86.2

package Exporter::Easy;
$Exporter::Easy::VERSION = '0.17';
use 5.006;
use strict;
use warnings;

require Exporter;
use vars;


sub import
{
	my $pkg = shift;

	unshift(@_, scalar caller);

	# must goto or we lose the use vars functionality

	goto &set_export_vars;
}

sub set_export_vars
{
	# this handles setting up all of the EXPORT variables in the callers
	# package. It gives a nice way of creating tags, allows you to use tags
	# when defining @EXPORT, @EXPORT_FAIL and other in tags. It also takes
	# care of @EXPORT_OK.

	my ($callpkg, %args) = @_;

	my %could_export; # symbols that could be exported
	my @will_export; # symbols that will be exported by default
	my @fail; # symbols that should be tested before export
	my @ok_only; # the symbols that are ok to export

	my %tags; # will contain a ref hash of all tags

	@_ = (); # we'll be using this for vars to be use vars'd

	if ($args{OK_ONLY} and $args{OK})
	{
		nice_die("Can't use OK_ONLY and OK together");
	}

	my $isa = exists $args{ISA} ? delete $args{ISA} : 1;
	my $vars = exists $args{VARS} ? delete $args{VARS} : 1;

	if (my $tag_data = delete $args{'TAGS'})
	{
		nice_die("TAGS must be a reference to an array") unless ref($tag_data) eq 'ARRAY';

		add_tags($tag_data, \%tags);

		@could_export{map {@$_} values %tags} = ();
	}

	if (my $export = delete $args{'EXPORT'})
	{
		nice_die("EXPORT must be a reference to an array")
			unless ref($export) eq 'ARRAY';

		@will_export = eval { expand_tags($export, \%tags) };
		nice_die("$@while building the EXPORT list in $callpkg") if $@;
	}

	if (my $ok = delete $args{'OK'})
	{
		nice_die("OK must be a reference to a array") unless ref($ok) eq 'ARRAY';

		my @ok = eval { expand_tags($ok, \%tags) };
		nice_die("$@while building the \@EXPORT_OK") if $@;
		@could_export{@ok} = ();
	}

	my $ok_only = delete $args{'OK_ONLY'};
	if ($ok_only)
	{
		die("OK_ONLY must be a reference to a array") unless ref($ok_only) eq 'ARRAY';

		@ok_only = eval { expand_tags($ok_only, \%tags) };
		nice_die("$@while building the OK_ONLY list") if $@;

		@could_export{@ok_only} = ();
	}

	if (my $fail = delete $args{'FAIL'})
	{
		die "FAIL must be a reference to an array" unless ref($fail) eq 'ARRAY';

		@fail = eval { expand_tags($fail, \%tags) };
		nice_die("$@while building \@EXPORT_FAIL") if $@;
		@could_export{@fail} = ();
	}

	my @could_export = keys %could_export;

	if (defined(my $all = delete $args{'ALL'}))
	{
		nice_die("No name supplied for ALL") unless length($all);

		nice_die("Cannot use '$all' for ALL, already exists") if exists $tags{$all};

		my %all;
		@all{@could_export, @will_export} = ();

		$tags{$all} = [keys %all];
	}

	if ($vars)
	{
		if (my $ref = ref($vars))
		{
			nice_die("VARS was a reference to a ".$ref." instead of an array")
				unless $ref eq 'ARRAY';
			@_ = ('vars', grep /^(?:\$|\@|\%)/, eval { expand_tags($vars, \%tags) });
			nice_die("$@while building the \@EXPORT") if $@;
		}
		else
		{
			@_ = ('vars', grep /^(?:\$|\@|\%)/, @will_export, @could_export);
		}
	}

	if (%args)
	{
		nice_die("Attempt to use unknown keys: ", join(", ", keys %args));
	}

	no strict 'refs';
	if ($isa)
	{
		push(@{"$callpkg\::ISA"}, "Exporter");
	}

	@{"$callpkg\::EXPORT"} = @will_export if @will_export;
	%{"$callpkg\::EXPORT_TAGS"} = %tags if %tags;
	@{"$callpkg\::EXPORT_OK"} = $ok_only ? @ok_only : @could_export;
	@{"$callpkg\::EXPORT_FAIL"} = @fail if @fail;

	if (@_ > 1)
	{
		goto &vars::import;
	}
}

sub nice_die
{
	my $msg = shift;
	my $level = shift || 1;

	my ($pkg, $file, $line) = caller(1);

	die "$msg at $file line $line\n";
}

sub add_tags($;$)
{
	# this takes a reference to tag data and an optional reference to a hash
	# of already exiting tags. If no hash ref is supplied then it creates an
	# empty one

	# It adds the tags from the tag data to the hash ref.

	my $tag_data = shift;
	my $tags = shift || {};

	my @tag_data = @$tag_data;
	while (@tag_data)
	{
		my $tag_name = shift @tag_data || die "No name for tag";
		die "Tag name cannot be a reference, maybe you left out a comma"
			if (ref $tag_name);

		die "Tried to redefine tag '$tag_name'"
			if (exists $tags->{$tag_name});

		my $tag_list = shift @tag_data || die "No values for tag '$tag_name'";

		die "Tag values for '$tag_name' is not a reference to an array"
			unless ref($tag_list) eq 'ARRAY';

		my @symbols = eval { expand_tags($tag_list, $tags) };
		die "$@while building tag '$tag_name'" if $@;

		$tags->{$tag_name} = \@symbols;
	}

	return $tags;
}

sub expand_tags($$)
{
	# this takes a list of strings. Each string can be a symbol, or a tag and
	# each may start with a ! to signify deletion.

	# We return a list of symbols where all the tag have been expanded and
	# some symbols may have been deleted

	# we die if we hit an unknown tag

	my ($string_list, $so_far) = @_;

	my %this_tag;

	foreach my $sym (@$string_list)
	{
		my @symbols; # list of symbols to add or delete
		my $remove = 0;

		if ($sym =~ s/^!//)
		{
			$remove = 1;
		}

		if ($sym =~ s/^://)
		{
			my $sub_tag = $so_far->{$sym};
			die "Tried to use an unknown tag '$sym'" unless defined($sub_tag);

			if ($remove)
			{
				delete @this_tag{@$sub_tag}
			}
			else
			{
				@this_tag{@$sub_tag} = ();
			}
		}
		else
		{
			if ($remove)
			{
				delete $this_tag{$sym};
			}
			else
			{
				$this_tag{$sym} = undef;
			}
		}
	}

	return keys %this_tag;
}

1;
__END__