view release on metacpan or  search on metacpan

lib/Exporter/Extensible.pm  view on Meta::CPAN

package Exporter::Extensible;
use v5;
use strict; no strict 'refs';
use warnings; no warnings 'redefine';
require Exporter::Extensible::Compat if "$]" < "5.012";
require mro;

# ABSTRACT: Create easy-to-extend modules which export symbols
our $VERSION = '0.11'; # VERSION

our %EXPORT_FAST_SUB_CACHE;
our %EXPORT_PKG_CACHE;
our %EXPORT_TAGS_PKG_CACHE;

our %EXPORT= (
	-exporter_setup => [ 'exporter_setup', 1 ],
);

our %sigil_to_reftype= (
	'$' => 'SCALAR',
	'@' => 'ARRAY',
	'%' => 'HASH',
	'*' => 'GLOB',
	'&' => 'CODE',
	''  => 'CODE',
	'-' => 'CODE',
);
our %reftype_to_sigil= (
	'SCALAR' => '$',
	'ARRAY'  => '@',
	'HASH'   => '%',
	'GLOB'   => '*',
	'CODE'   => '',
);
our %sigil_to_generator_prefix= (
	'$' => [ '_generateSCALAR_', '_generateScalar_' ],
	'@' => [ '_generateARRAY_', '_generateArray_' ],
	'%' => [ '_generateHASH_', '_generateHash_' ],
	'*' => [ '_generateGLOB_', '_generateGlob_' ],
	'&' => [ '_generate_', '_generateCODE_', '_generateCode' ],
);
$sigil_to_generator_prefix{''}= $sigil_to_generator_prefix{'&'};
our %ord_is_sigil= ( ord '$', 1, ord '@', 1, ord '%', 1, ord '*', 1, ord '&', 1, ord '-', 1, ord ':', 1 );
our %ord_is_directive= ( ord '-', 1, ord ':', 1 );

my ($carp, $croak, $weaken, $colon, $hyphen);
$carp=   sub { require Carp; $carp= \&Carp::carp; goto $carp; };
$croak=  sub { require Carp; $croak= \&Carp::croak; goto $croak; };
$weaken= sub { require Scalar::Util; $weaken= \&Scalar::Util::weaken; goto $weaken; };
$colon= ord ':';
$hyphen= ord '-';

sub import {
	my $self= shift;
	# Can be called as class method or instance method
	$self= bless { into => scalar caller }, $self
		unless ref $self;
	# Optional config hash might be given as first argument
	$self->exporter_apply_global_config(shift)
		if ref $_[0] eq 'HASH';
	my $class= ref $self;
	my @todo= @_? @_ : @{ $self->exporter_get_tag('default') || [] };
	return 1 unless @todo;
	# If only installing subs without generators or unusual options, use a more direct code path.
	# This only takes effect the second time a symbol is requested, since the cache is not pre-populated.
	# (abuse a while loop as a if/goto construct)
	fast: while (!$self->{_complex} && !grep ref, @todo) {
		my $fastsub= $EXPORT_FAST_SUB_CACHE{$class} || last; # can't optimize if no cache is built
		my $prefix= $self->{into}.'::'; # {into} can be a hashref, but not when {_complex} is false
		my $replace= $self->{replace} || 'carp';
		if ($replace eq 'carp') {
			# Use perl's own warning system to detect attempts to overwrite the GLOB.  Only warn if the
			# new reference isn't the same as existing.
			use warnings 'redefine';
			local $SIG{__WARN__}= sub { *{$prefix.$_}{CODE} == $fastsub->{$_} or $carp->($_[0]) };
			ord == $colon || (*{$prefix.$_}= ($fastsub->{$_} || last fast))
				for @todo;
		}
		elsif ($replace eq 1) {
			ord == $colon || (*{$prefix.$_}= ($fastsub->{$_} || last fast))
				for @todo;
		}
		else { last } # replace==croak and replace==skip require more logic
		# Now apply any tags that were requested.  Each will get its own determination of whether it
		# can use the 'fast' method.
		ord == $colon && $self->import(@{$self->exporter_get_tag(substr $_, 1)})
			for @todo;
		return 1;
	}
	my $install= $self->_exporter_build_install_set(\@todo);

	# Install might actually be uninstall.  It also might be overridden by the user.
	# The exporter_combine_config sets this up so we don't need to think about details.
	my $method= $self->{installer} || ($self->{no}? 'exporter_uninstall' : 'exporter_install');
	# Convert
	#    { foo => { SCALAR => \$foo, HASH => \%foo } }
	# into
	#    [ foo => \$foo, foo => \%foo ]
	my @flat_install= %$install;
	for my $i (reverse 1..$#flat_install) {
		if (ref $flat_install[$i] eq 'HASH') {
			splice @flat_install, $i-1, 2, map +($flat_install[$i-1] => $_), values %{$flat_install[$i]};
		}
	}
	# Then pass that list to the installer (or uninstaller)
	$self->$method(\@flat_install);
	# If scope requested, create the scope-guard object
	if (my $scope= $self->{scope}) {
		$$scope= bless [ $self, \@flat_install ], 'Exporter::Extensible::UnimportScopeGuard';
		$weaken->($self->{scope});
	}
	# It's entirely likely that a generator might curry $self inside the sub it generated.
	# So, we end up with a circular reference if we're holding onto the set of all things we
	# exported.  Clear the set.
	%$install= ();
	1;
}

sub _exporter_build_install_set {
	my ($self, $todo)= @_;
	$self->{todo}= $todo;
	my $install= $self->{install_set} ||= {};
	my $inventory= $EXPORT_PKG_CACHE{ref $self} ||= {};
	while (@$todo) {
		my $symbol= shift @$todo;

		# If it is a tag, then recursively call import on that list
		if (ord $symbol == $colon) {
			my $name= substr $symbol, 1;
			my $tag_cache= $self->exporter_get_tag($name)
				or $croak->("Tag ':$name' is not exported by ".ref($self));
			# If first element of tag is a hashref, they count as nested global options.
			# If tag was followed by hashref, those are user-supplied options.
			if (ref $tag_cache->[0] eq 'HASH' || ref $todo->[0] eq 'HASH') {
				$tag_cache= [ @$tag_cache ]; # don't destroy cache
				my $self2= $self;
				$self2= $self2->exporter_apply_global_config(shift @$tag_cache)
					if ref $tag_cache->[0] eq 'HASH';
				$self2= $self2->exporter_apply_inline_config(shift @$todo)
					if ref $todo->[0] eq 'HASH';
				if ($self != $self2) {
					$self2->_exporter_build_install_set($tag_cache);
					next;
				}
			}
			unshift @$todo, @$tag_cache;
			next;
		}
		# Else, it is an option or plain symbol to be exported
		# Check current package cache first, else do the full lookup.
		my $ref= (exists $inventory->{$symbol}? $inventory->{$symbol} : $self->exporter_get_inherited($symbol))
			or $croak->("'$symbol' is not exported by ".ref($self));

		# If it starts with '-', it is an option, and might consume additional args
		if (ord $symbol == $hyphen) {
			# back-compat for when opt was arrayref
			if (ref $ref eq 'ARRAY') {
				my ($method, $count)= @$ref;
				$ref= $self->_exporter_wrap_option_handler($method, $count);
			}
			$self->$ref;
		}
		else {
			my ($sigil, $name)= $ord_is_sigil{ord $symbol}? ( substr($symbol,0,1), substr($symbol,1) ) : ( '', $symbol );
			my $self2= $self;
			# If followed by a hashref, add those options to the current ones.
			$self2= $self->exporter_apply_inline_config(shift @$todo)
				if ref $todo->[0] eq 'HASH';
			if ($self2->{_name_mangle}) {
				next if defined $self2->{not} and $self2->_exporter_is_excluded($symbol);