File Coverage

blib/lib/Exporter/Extensible.pm

Criterion	Covered	Total	%
statement	340	383	88.7
branch	180	284	63.3
condition	108	213	50.7
subroutine	43	49	87.7
pod	9	25	36.0
total	680	954	71.2

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.08'; # 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) {
			my ($method, $count)= @$ref;
			if ($count eq '*') {
				my $consumed= $self->$method(@$todo);
				$consumed =~ /^[0-9]+$/ or $croak->("Method $method in ".ref($self)." must return a number of arguments consumed");
				splice(@$todo, 0, $consumed);
			}
			elsif ($count eq '?') {
				if (ref $todo->[0]) {
					my $arg= shift @$todo;
					(ref $arg eq 'HASH'? $self->exporter_apply_inline_config($arg) : $self)
						->$method($arg);
				} else {
					$self->$method();
				}
			}
			else {
				$self->$method(splice(@$todo, 0, $count));
			}
		}
		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);
				$name= delete $self2->{as} || ($self2->{prefix}||'') . $name . ($self2->{suffix}||'');
				# If 'as' was the only reason for _name_mangle, then disable it to return to fast-path
				delete $self2->{_name_mangle} unless defined $self2->{prefix} || defined $self2->{suffix} || defined $self2->{not};
			}
			# If $ref is a generator (ref-ref) then run it, unless it was already run for the
			# current symbol exporting to the current dest.
			if (ref $ref eq 'REF') {
				$ref= $self2->{_generator_cache}{$symbol.";".$name} ||= do {
					# Run the generator.
					my $method= $$ref;
					$method= $$method unless ref $method eq 'CODE';
					$self2->$method($symbol, $self2->{generator_arg});
				};
				# Verify generator output matches sigil
				ref $ref eq $sigil_to_reftype{$sigil} or (ref $ref eq 'REF' && $sigil eq '$')
					or $croak->("Trying to export '$symbol', but generator returned "
						.ref($ref).' (need '.$sigil_to_reftype{$sigil}.')');
			}
			# Check for collisions.  Unlikely scenario in typical usage, but could occur if two
			# tags include the same symbol, or if user adds a prefix or suffix that collides
			# with another exported name.
			if ($install->{$name}) {
				if ($install->{$name} != $ref) { # most common case of duplicate export, ignore it.
					if (ref $ref eq 'GLOB' || ref $install->{$name} eq 'GLOB') {
						# globrefs will never be equal - compare the glob itself.
						ref $ref eq 'GLOB' && ref $install->{dest} eq 'GLOB' && *{$install->{$name}} eq *$ref
							# can't install an entire glob at the same time as a piece of a glob.
							or $croak->("Can't install ".ref($ref)." and ".$install->{dest}." into the same symbol '".$name."'");
					}
					# Upgrade this item to a hashref of reftype if it wasn't already  (hashrefs are always stored this way)
					$install->{$name}= { ref($install->{$name}) => $install->{$name} }
						unless ref $install->{$name} eq 'HASH';
					# Assign this new ref into a slot of that hash, unless something different was already there
					($install->{$name}{ref $ref} ||= $ref) == $ref
						or $croak->("Trying to import conflicting ".ref($ref)." values for '".$name."'");
				}
			}
			# Only make install->{$name} a hashref if we really have to, for performance.
			elsif (ref $ref eq 'HASH') {
				$install->{$name}{HASH}= $ref;
			}
			else {
				$install->{$name}= $ref;
			}
		}
	}
	return $install;
}

sub Exporter::Extensible::UnimportScopeGuard::clean {
	my $self= shift;
	$self->[0]->exporter_uninstall($self->[1]) if $self->[1];
	$self->[1]= undef; # Ignore subsequent calls
}

sub Exporter::Extensible::UnimportScopeGuard::DESTROY {
	shift->clean;
}

sub exporter_install {
	my $self= shift;
	my $into= $self->{into} or $croak->("'into' must be defined before exporter_install");
	return $self->_exporter_install_to_ref(@_) if ref $into;
	my $replace= $self->{replace} || 'warn';
	my $stash= \%{$into.'::'};
	my $list= @_ == 1 && ref $_[0] eq 'ARRAY'? $_[0] : \@_;
	for (my $i= 0; $i < @$list; $i+= 2) {
		my ($name, $ref)= @{$list}[$i..1+$i];
		my $pkg_dest= $into.'::'.$name;
		# Each value is either a hashref with keys matching the parts of a typeglob,
		# or it is a single ref that can be assigned directly to the typeglob.
		if (defined $stash->{$name} and $replace ne 1) {
			# there is actually no way I know of to test existence of *foo{SCALAR}.
			# It auto-vivifies when accessed.
			my $conflict= (ref $ref eq 'GLOB')? $stash->{$name} ne *$ref
				: (ref $ref eq 'SCALAR')? 0 # TODO: How to test existence of *foo{SCALAR} ?  It auto-vivifies
				: (*$pkg_dest{ref $ref} && *$pkg_dest{ref $ref} != $ref);
			if ($conflict) {
				next if $replace eq 'skip';
				$name= $reftype_to_sigil{ref $ref} . $name; # include sigil for user's benefit
				$replace eq 'warn'? $carp->("Overwriting '$name' with $ref from ".ref($self))
					: $croak->("Refusing to overwrite '$name' with $ref from ".ref($self));
			}
		}
		*$pkg_dest= $ref;
	}
}

sub exporter_uninstall {
	my $self= shift;
	my $into= $self->{into} or $croak->("'into' must be defined before exporter_uninstall");
	return $self->_exporter_install_to_ref(@_) if ref $into;
	my $stash= \%{$into.'::'};
	my $list= @_ == 1 && ref $_[0] eq 'ARRAY'? $_[0] : \@_;
	for (my $i= 0; $i < @$list; $i+= 2) {
		my ($name, $ref)= @{$list}[$i..1+$i];
		# Each value is either a hashref with keys matching the parts of a typeglob,
		# or it is a single ref that can be assigned directly to the typeglob.
		if (ref $ref eq 'GLOB') {
			# If the value we installed is no longer there, do nothing
			next unless *$ref eq ($stash->{$name}||'');
			delete $stash->{$name};
		}
		else {
			my $pkg_dest= $into.'::'.$name;
			# If the value we installed is no longer there, do nothing
			next unless $ref == (*{$pkg_dest}{ref $ref}||0);
			# Remove old typeglob, then copy all slots except reftype back to that typeglob name
			my $old= delete $stash->{$name};
			($_ ne ref $ref) && *{$old}{$_} && (*$pkg_dest= *{$old}{$_})
				for qw( SCALAR HASH ARRAY CODE IO );
		}
	}
}

sub _exporter_install_to_ref {
	my $self= shift;
	my $into= $self->{into};
	ref $into eq 'HASH' or $croak->("'into' must be a hashref");
	my $replace= $self->{replace} || 'warn';
	my $list= @_ == 1 && ref $_[0] eq 'ARRAY'? $_[0] : \@_;
	for (my $i= 0; $i < @$list; $i+= 2) {
		my ($name, $ref)= @{$list}[$i..1+$i];
		$name= $reftype_to_sigil{ref $ref} . $name; # include sigil when installing to hashref
		if ($self->{no}) {
			delete $into->{$name};
		}
		else {
			if (defined $into->{$name} && $into->{name} != $ref) {
				$replace eq 'skip' and next;
				$replace eq 'warn' and $carp->("Overwriting '$name' with $ref from ".ref($self));
				$replace eq 'die' and $croak->("Refusing to overwrite '$name' with $ref from ".ref($self));
			}
			$into->{$name}= $ref;
		}
	}
}

sub exporter_config_prefix    { $_[0]->_exporter_set_attr(prefix => $_[1]) if @_ > 1; $_[0]{prefix} }
sub exporter_config_suffix    { $_[0]->_exporter_set_attr(suffix => $_[1]) if @_ > 1; $_[0]{suffix} }
sub exporter_config_as        { $_[0]->_exporter_set_attr(as     => $_[1]) if @_ > 1; $_[0]{as} }
sub exporter_config_no        { $_[0]->_exporter_set_attr(no     => $_[1]) if @_ > 1; $_[0]{no} }
sub exporter_config_into      { $_[0]->_exporter_set_attr(into   => $_[1]) if @_ > 1; $_[0]{into} }
sub exporter_config_scope     { $_[0]->_exporter_set_attr(scope  => $_[1]) if @_ > 1; $_[0]{scope};     }
sub exporter_config_not       { $_[0]->_exporter_set_attr(not    => $_[1]) if @_ > 1; $_[0]{not};       }
sub exporter_config_installer { $_[0]->_exporter_set_attr(installer => $_[1]) if @_ > 1; $_[0]{installer}; }

sub _exporter_set_attr {
	my ($self, $name, $val)= @_;
	$self->{$name}= $val;
	# After changing config, update the optimization flags.
	# _name_mangle is set if there is any deviation from normal installation of the symbol name
	$self->{_name_mangle}= defined $self->{not}
		|| defined $self->{as}
		|| (defined $self->{prefix} && length $self->{prefix})
		|| (defined $self->{suffix} && length $self->{suffix});
	# _complex is set if the required algorithm is anything more than a simple *{$into.'::'.$name}= $ref
	# but 'replace' does not trigger _complex currently because I handled that in the fast installer.
	$self->{_complex}= $self->{no} || $self->{_name_mangle}
		|| defined $self->{scope}
		|| $self->{installer} || ref $self->{into};
}

our %replace_aliases= (
	1     => 1,
	carp  => 'carp',
	warn  => 'carp',
	croak => 'croak',
	fatal => 'croak',
	die   => 'croak',
	skip  => 'skip',
);
sub exporter_config_replace {
	$_[0]{replace}= $replace_aliases{$_[1]} or $croak->("Invalid 'replace' value: '$_[1]'")
		if @_ > 1;
	$_[0]{replace};
}

sub exporter_apply_global_config {
	my ($self, $conf)= @_;
	for my $k (keys %$conf) {
		my $setter= $self->can('exporter_config_'.$k)
			or (substr($k,0,1) eq '-' && $self->can('exporter_config_'.substr($k,1)))
			or $croak->("No such exporter configuration '$k'");
		$self->$setter($conf->{$k});
	}
	$self;
}

sub exporter_apply_inline_config {
	my ($self, $conf)= @_;
	my @for_global_config= grep ord == $hyphen, keys %$conf;
	# In the event that only "-as" was given, we don't actually need to create a new object
	if (@for_global_config == 1 && $for_global_config[0] eq '-as' && keys %$conf == 1) {
		$self->exporter_config_as($conf->{-as});
		return $self;
	}
	# Else clone and apply temporary settings
	my $self2= bless { %$self, parent => $self }, ref $self;
	for my $k (@for_global_config) {
		my $setter= $self2->can('exporter_config_'.substr($k,1))
			or $croak->("No such exporter configuration '$k'");
		$self2->$setter($conf->{$k});
	}
	# If any options didn't start with '-', then the config becomes a parameter to the generator.
	# The generator cache isn't valid for $self2 since the arg changed.
	if (@for_global_config < scalar keys %$conf) {
		$self2->{generator_arg}= $conf;
		delete $self2->{_generator_cache};
	}
	$self2;
}

sub unimport {
	# If first option is a hashref (global options), merge that with { no => 1 }
	my %opts= ( (ref $_[1] eq 'HASH'? %{splice(@_,1,1)} : () ), no => 1 );
	# Use this as the global options
	splice @_, 1, 0, \%opts;
	goto $_[0]->can('import'); # to preserve caller
}

sub import_into {
	shift->import({ into => shift, (ref $_[0] eq 'HASH'? %{+shift} : ()) }, @_);
}

sub exporter_register_symbol {
	my ($class, $export_name, $ref)= @_;
	$class= ref($class)||$class;
	$ref ||= $class->_exporter_get_ref_to_package_var($export_name)
		or $croak->("Symbol $export_name not found in package $class");
	${$class.'::EXPORT'}{$export_name}= $ref;
}

sub exporter_autoload_symbol {
	my ($class, $export_name)= @_;
	return;
}

sub exporter_get_inherited {
	my ($self, $sym)= @_;
	my $class= ref($self)||$self;
	# Make the common case fast.
	return $EXPORT_PKG_CACHE{$class}{$sym} ||=
		do {
			my $x;
			# quick check of own package first
			unless ($x= ${$class.'::EXPORT'}{$sym}) {
				# search package hierarchy
				($x= ${$_.'::EXPORT'}{$sym}) && last for @{ mro::get_linear_isa($class) }
			}
			# If it is a plain sub, it is elligible for "fast export"
			$EXPORT_FAST_SUB_CACHE{$class}{$sym}= $x if ref $x eq 'CODE' and !$ord_is_sigil{ord $sym};
			#print "# ref=".ref($x)." sym=$sym\n";
			$x;
		}
		# Isn't exported, but maybe autoload.
		|| $self->exporter_autoload_symbol($sym);
}

sub exporter_register_option {
	my ($class, $option_name, $method_name, $arg_count)= @_;
	$class= ref($class)||$class;
	${$class.'::EXPORT'}{'-'.$option_name}= [ $method_name, $arg_count||0 ];
}

sub exporter_register_generator {
	my ($class, $export_name, $method_name)= @_;
	$class= ref($class)||$class;
	if (ord $export_name == $colon) {
		(${$class.'::EXPORT_TAGS'}{substr($export_name,1)} ||= $method_name) eq $method_name
			or $croak->("Cannot set generator for $export_name when that tag is already populated within this class ($class)");
	} else {
		# If method name is a scalar, make it a scalar-ref-ref.  If it is a coderef, make it a coderef-ref
		${$class.'::EXPORT'}{$export_name}= ref $method_name? \$method_name : \\$method_name;
	}
}

sub exporter_register_tag_members {
	my ($class, $tag_name)= (shift, shift);
	$class= ref($class)||$class;
	push @{ ${$class.'::EXPORT_TAGS'}{$tag_name} }, @_;
}

sub _exporter_build_tag_cache {
	my ($self, $tagname)= @_;
	my $class= ref($self)||$self;
	# Collect all members of this tag from any parent class, but stop at the first undef
	my ($dynamic, @keep, %seen, $known);
	for (@{ mro::get_linear_isa($class) }) {
		my $add= ${$_.'::EXPORT_TAGS'}{$tagname}
			# Special case, ':all' is built from all known keys of the %EXPORT var at each inherited package
			# Also exclude anything exported as part of the Exporter API, but right now that is only
			# the '-exporter_setup' option.
			|| ($tagname eq 'all' && defined *{$_.'::EXPORT'}{HASH}
				&& [ grep !$ord_is_directive{+ord}, keys %{$_.'::EXPORT'} ]
			)
			or next;
		++$known;
		if (ref $add ne 'ARRAY') {
			# Found a generator (coderef or method name ref).  Call it to get the list of tags.
			$add= ref $add eq 'CODE'? $add
				: ref $add eq 'SCALAR'? $$add
				: $croak->("Tag must expand to an array, code, or a method name ref (not $add)");
			$add= $self->$add($self->{generator_arg});
			ref $add eq 'ARRAY' or $croak->("Tag generator must return an arrayref");
			++$dynamic;
		}
		# If first element of the list is undef it means this class wanted to reset the tag.
		# Since we're iterating *up* the hierarchy, it just means end here.
		my $start= (@$add && !defined $add->[0])? 1 : 0;
		# symbol might be followed by options, so need to skip over refs, but also need to allow
		# duplicate symbols if they were followed by a ref.
		(ref $add->[$_] || !$seen{$add->[$_]}++ || ref $add->[$_+1]) && push @keep, $add->[$_]
			for $start .. $#$add;
		last if $start;
	}
	my $ret= $known? \@keep : $self->exporter_autoload_tag($tagname);
	$EXPORT_TAGS_PKG_CACHE{$class}{$tagname}= $ret unless $dynamic;
	return $ret;
}

sub exporter_get_tag {
	my ($self, $tagname)= @_;
	my $class= ref($self)||$self;
	# Make the common case fast
	my $list= $EXPORT_TAGS_PKG_CACHE{$class}{$tagname};
	$list= $self->_exporter_build_tag_cache($tagname)
		unless $list or exists $EXPORT_TAGS_PKG_CACHE{$class}{$tagname};
	return $list;
}

sub _exporter_is_excluded {
	my ($self, $symbol)= @_;
	return unless ref $self && (my $not= $self->{not});
	# N^2 exclusion iteration isn't cool, but doing something smarter requires a
	# lot more setup that probably won't pay off for the usual tiny lists of 'not'.
	for my $filter (ref $not eq 'ARRAY'? @$not : ($not)) {
		if (!ref $filter) {
			return 1 if $symbol eq $filter;
		}
		elsif (ref $filter eq 'Regexp') {
			return 1 if $symbol =~ $filter;
		}
		elsif (ref $filter eq 'CODE') {
			&$filter && return 1 for $symbol;
		}
		else { $croak->("Unhandled 'not' filter: $filter") }
	}
	return;
}

sub exporter_autoload_tag {
	my ($self, $tagname)= @_;
	return;
}

sub exporter_also_import {
	my $self= shift;
	ref $self && $self->{todo} or $croak->('exporter_also_import can only be called on $self during an import()');
	push @{$self->{todo}}, @_;
}

my %method_attrs;
sub FETCH_CODE_ATTRIBUTES {
	my ($class, $coderef)= (shift, shift);
	my $super= $class->next::can;
	return @{$method_attrs{$class}{$coderef} || []},
		($super? $super->($class, $coderef, @_) : ());
}
sub MODIFY_CODE_ATTRIBUTES {
	my ($class, $coderef)= (shift, shift);
	my @unknown= grep !$class->_exporter_process_attribute($coderef, $_), @_;
	my $super= $class->next::can;
	return $super? $super->($class, $coderef, @unknown) : @unknown;
}

sub _exporter_get_coderef_name {
	# Sub::Identify has an XS version that we take advantage of if available
	my $impl= (eval 'require Sub::Identify;1')? sub {
			&Sub::Identify::sub_name
				or $croak->("Can't determine export name of $_[0]");
		}
		: do {
			require B;
			sub {
				my $cv= &B::svref_2object;
				$cv->isa('B::CV') && !$cv->GV->isa('B::SPECIAL') && $cv->GV->NAME
					or $croak->("Can't determine export name of $_[0]");
			};
		};
	*_exporter_get_coderef_name= $impl;
	$impl->(shift);
}

sub _exporter_get_ref_to_package_var {
	my ($class, $sigil, $name)= @_;
	unless (defined $name) {
		($sigil, $name)= ($_[1] =~ /^([\$\@\%\*\&]?)(\w+)$/)
			or $croak->("'$_[1]' is not an allowed variable name");
	}
	my $reftype= $sigil_to_reftype{$sigil};
	return undef unless ${$class.'::'}{$name};
	return $reftype eq 'GLOB'? \*{$class.'::'.$name} : *{$class.'::'.$name}{$reftype};
}

sub _exporter_process_attribute {
	my ($class, $coderef, $attr)= @_;
	if ($attr =~ /^Export(?:\(\s*(.*?)\s*\))?$/) {
		my (%tags, $subname, @export_names);
		# If given a list in parenthesees, split on space and proces each.  Else use the name of the sub itself.
		for my $token ($1? split(/\s+/, $1) : ()) {
			if ($token =~ /^:(.*)$/) {
				$tags{$1}++; # save tags until we have the export_names
			}
			elsif ($token =~ /^\w+$/) {
				push @export_names, $token;
				${$class.'::EXPORT'}{$token}= $coderef;
			}
			elsif ($token =~ /^-(\w*)(?:\(([0-9]+|\*)\))?$/) {
				$subname ||= _exporter_get_coderef_name($coderef);
				push @export_names, length $1? $token : "-$subname";
				$class->exporter_register_option(substr($export_names[-1],1), $subname, $2);
			}
			elsif (my($sym, $name)= ($token =~ /^=([\&\$\@\%\*:]?(\w*))$/)) {
				$subname ||= _exporter_get_coderef_name($coderef);
				my $export_name= length $name? $sym : do {
					(my $x= $subname) =~ s/^_generate[A-Za-z]*_//;
					$sym . $x
				};
				$export_name =~ s/^[&]//;
				$class->exporter_register_generator($export_name, $subname);
				push @export_names, $export_name;
			}
			else {
				$croak->("Invalid export notation '$token'");
			}
		}
		if (!@export_names) { # if list was empty or only tags...
			push @export_names, _exporter_get_coderef_name($coderef);
			${$class.'::EXPORT'}{$export_names[-1]}= $coderef;
		}
		$class->exporter_register_tag_members($_, @export_names) for keys %tags;
		return 1;
	}
	return;
}

sub exporter_setup {
	my ($self, $version)= @_;
	push @{$self->{into}.'::ISA'}, ref($self);
	strict->import;
	warnings->import;
	if ($version == 1) {
		# Declare 'our %EXPORT'
		*{$self->{into}.'::EXPORT'}= \%{$self->{into}.'::EXPORT'};
		# Make @EXPORT and $EXPORT_TAGS{default} be the same arrayref.
		# Allow either one to have been declared already.
		my $tags= \%{$self->{into}.'::EXPORT_TAGS'};
		*{$self->{into}.'::EXPORT'}= $tags->{default}
			if ref $tags->{default} eq 'ARRAY';
		$tags->{default} ||= \@{$self->{into}.'::EXPORT'};
		# Export the 'export' function.
		*{$self->{into}.'::export'}= \&_exporter_export_from_caller;
	}
	elsif ($version) {
		$croak->("Unknown export API version $version");
	}
}

sub _exporter_export_from_caller {
	unshift @_, scalar caller;
	goto $_[0]->can('exporter_export');
}
sub exporter_export {
	my $class= shift;
	for (my $i= 0; $i < @_;) {
		my ($is_gen, $sigil, $name, $args, $ref);
		my $export= $_[$i++];
		ref $export and $croak->("Expected non-ref export name at argument $i");
		# If they provided the ref, capture it from arg list.
		$ref= $_[$i++] if ref $_[$i];
		# Common case first - ordinary functions
		if ($export =~ /^\w+$/) {
			$ref ||= $class->can($export) or $croak->("Export '$export' not found in $class");
			${$class.'::EXPORT'}{$export}= $ref;
		}
		# Next, check for generators or variables with sigils
		elsif (($is_gen, $sigil, $name)= ($export =~ /^(=?)([\$\@\%\*]?)(\w+)$/)) {
			$ref ||= $class->_exporter_get_ref_to_package_var($sigil, $name)
				unless $is_gen;
			if (!$ref) {
				for (@{ $sigil_to_generator_prefix{$sigil} }) {
					my $gen= $_ . $name;
					next unless $class->can($gen);
					$ref= \\$gen;  # REF REF to method name
					last;
				}
				$ref or $croak->("Export '$export' not found in package $class, nor a generator $sigil_to_generator_prefix{$sigil}[0]");
			}
			elsif ($is_gen) {
				ref $ref eq 'CODE' or $croak->("Export '$export' should be followed by a generator coderef");
				my $coderef= $ref;
				$ref= \$coderef; # REF to coderef
			}
			else {
				ref $ref eq $sigil_to_reftype{$sigil} or (ref $ref eq 'REF' && $sigil eq '$')
					or $croak->("'$export' should be $sigil_to_reftype{$sigil} but you supplied ".ref($ref));
			}
			${$class.'::EXPORT'}{$sigil.$name}= $ref;
		}
		# Tags ":foo"
		elsif (($is_gen, $name)= ($export =~ /^(=?):(\w+)$/)) {
			if ($is_gen && !$ref) {
				my $gen= $sigil_to_generator_prefix{':'}.$name;
				$class->can($gen)
					or $croak->("Can't find generator for tag $name : '$gen'");
				$ref= $gen;
			}
			ref $ref eq 'ARRAY'? $class->exporter_register_tag_members($name, @$ref)
				: $class->exporter_register_generator($export, $ref);
		}
		# Options "-foo" or "-foo(3)"
		elsif (($name, $args)= ($export =~ /^-(\w+)(?:\(([0-9]+|\*|\?)\))?$/)) {
			if ($ref) {
				ref $ref eq 'CODE' or (ref $ref eq 'SCALAR' and $class->can($ref= $$ref))
					or $croak->("Option '$export' must be followed by coderef or method name as scalar ref");
			} else {
				$class->can($name)
					or $croak->("Option '$export' defaults to a method '$name' which does not exist on $class");
				$ref= $name;
			}
			$class->exporter_register_option($name, $ref, $args);
		}
		else {
			$croak->("'$export' is not a valid export syntax");
		}
	}
}

1;

__END__