view release on metacpan or  search on metacpan

local/lib/perl5/Exporter/Tiny.pm  view on Meta::CPAN

package Exporter::Tiny;

use 5.006001;
use strict;
use warnings; no warnings qw(void once uninitialized numeric redefine);

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '1.006002';
our @EXPORT_OK = qw< mkopt mkopt_hash _croak _carp >;

BEGIN {
	*_HAS_NATIVE_LEXICAL_SUB = ( $] ge '5.037002' )
		? sub () { !!1 }
		: sub () { !!0 };
	*_HAS_MODULE_LEXICAL_SUB = ( $] ge '5.011002' and eval('require Lexical::Sub') )
		? sub () { !!1 }
		: sub () { !!0 };
};

sub _croak ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::croak }
sub _carp  ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::carp }

my $_process_optlist = sub
{
	my $class = shift;
	my ($global_opts, $opts, $want, $not_want) = @_;
	
	while (@$opts)
	{
		my $opt = shift @{$opts};
		my ($name, $value) = @$opt;
		
		($name =~ m{\A\!(/.+/[msixpodual]*)\z}) ?
			do {
				my @not = $class->_exporter_expand_regexp("$1", $value, $global_opts);
				++$not_want->{$_->[0]} for @not;
			} :
		($name =~ m{\A\![:-](.+)\z}) ?
			do {
				my @not = $class->_exporter_expand_tag("$1", $value, $global_opts);
				++$not_want->{$_->[0]} for @not;
			} :
		($name =~ m{\A\!(.+)\z}) ?
			(++$not_want->{$1}) :
		($name =~ m{\A[:-](.+)\z}) ?
			push(@$opts, $class->_exporter_expand_tag("$1", $value, $global_opts)) :
		($name =~ m{\A/.+/[msixpodual]*\z}) ?
			push(@$opts, $class->_exporter_expand_regexp($name, $value, $global_opts)) :
		# else ?
			push(@$want, $opt);
	}
};

sub import
{
	my $class = shift;
	my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
	
	if ( defined $global_opts->{into} and $global_opts->{into} eq '-lexical' ) {
		$global_opts->{lexical} = 1;
		delete $global_opts->{into};
	}
	if ( not defined $global_opts->{into} ) {
		$global_opts->{into} = caller;
	}
	
	my @want;
	my %not_want; $global_opts->{not} = \%not_want;
	my @args = do { no strict qw(refs); @_ ? @_ : @{"$class\::EXPORT"} };
	my $opts = mkopt(\@args);
	$class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
	
	$global_opts->{installer} ||= $class->_exporter_lexical_installer( $global_opts )
		if $global_opts->{lexical};
	

local/lib/perl5/Exporter/Tiny.pm  view on Meta::CPAN

	$class->_exporter_validate_opts($global_opts);
	
	for my $wanted (@want) {
		next if $not_want{$wanted->[0]};
		
		my %symbols = $class->_exporter_expand_sub(@$wanted, $global_opts, $permitted);
		$class->_exporter_install_sub($_, $wanted->[1], $global_opts, $symbols{$_})
			for keys %symbols;
	}
}

sub unimport
{
	my $class = shift;
	my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
	$global_opts->{is_unimport} = 1;
	
	if ( defined $global_opts->{into} and $global_opts->{into} eq '-lexical' ) {
		$global_opts->{lexical} = 1;
		delete $global_opts->{into};
	}
	if ( not defined $global_opts->{into} ) {
		$global_opts->{into} = caller;
	}
	
	my @want;
	my %not_want; $global_opts->{not} = \%not_want;
	my @args = do { our %TRACKED; @_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}}) };
	my $opts = mkopt(\@args);
	$class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
	
	my $permitted = $class->_exporter_permitted_regexp($global_opts);
	$class->_exporter_validate_unimport_opts($global_opts);
	
	my $expando = $class->can('_exporter_expand_sub');
	$expando = undef if $expando == \&_exporter_expand_sub;
	
	for my $wanted (@want)
	{
		next if $not_want{$wanted->[0]};
		
		if ($wanted->[1])
		{
			_carp("Passing options to unimport '%s' makes no sense", $wanted->[0])
				unless (ref($wanted->[1]) eq 'HASH' and not keys %{$wanted->[1]});
		}
		
		my %symbols = defined($expando)
			? $class->$expando(@$wanted, $global_opts, $permitted)
			: ($wanted->[0] => sub { "dummy" });
		$class->_exporter_uninstall_sub($_, $wanted->[1], $global_opts)
			for keys %symbols;
	}
}

# Returns a coderef suitable to be used as a sub installer for lexical imports.
#
sub _exporter_lexical_installer {
	_HAS_NATIVE_LEXICAL_SUB and return sub {
		my ( $sigilname, $sym ) = @{ $_[1] };
		no warnings ( $] ge '5.037002' ? 'experimental::builtin' : () );
		builtin::export_lexically( $sigilname, $sym );
	};
	_HAS_MODULE_LEXICAL_SUB and return sub {
		my ( $sigilname, $sym ) = @{ $_[1] };
		( $sigilname =~ /^\w/ )
			? 'Lexical::Sub'->import( $sigilname, $sym )
			: 'Lexical::Var'->import( $sigilname, $sym );
	};
	_croak( 'Lexical export requires Perl 5.37.2+ for native support, or Perl 5.11.2+ with the Lexical::Sub module' );
}

# Called once per import/unimport, passed the "global" import options.
# Expected to validate the options and carp or croak if there are problems.
# Can also take the opportunity to do other stuff if needed.
#
sub _exporter_validate_opts          { 1 }
sub _exporter_validate_unimport_opts { 1 }

# Called after expanding a tag or regexp to merge the tag's options with
# any sub-specific options.
#
sub _exporter_merge_opts
{
	my $class = shift;
	my ($tag_opts, $global_opts, @stuff) = @_;
	
	$tag_opts = {} unless ref($tag_opts) eq q(HASH);
	_croak('Cannot provide an -as option for tags')
		if exists $tag_opts->{-as} && ref $tag_opts->{-as} ne 'CODE';
	
	my $optlist = mkopt(\@stuff);
	for my $export (@$optlist)
	{
		next if defined($export->[1]) && ref($export->[1]) ne q(HASH);
		
		my %sub_opts = ( %{ $export->[1] or {} }, %$tag_opts );
		$sub_opts{-prefix} = sprintf('%s%s', $tag_opts->{-prefix}, $export->[1]{-prefix})
			if exists($export->[1]{-prefix}) && exists($tag_opts->{-prefix});
		$sub_opts{-suffix} = sprintf('%s%s', $export->[1]{-suffix}, $tag_opts->{-suffix})
			if exists($export->[1]{-suffix}) && exists($tag_opts->{-suffix});
		$export->[1] = \%sub_opts;
	}
	return @$optlist;
}

# Given a tag name, looks it up in %EXPORT_TAGS and returns the list of
# associated functions. The default implementation magically handles tags
# "all" and "default". The default implementation interprets any undefined
# tags as being global options.
# 
sub _exporter_expand_tag
{
	no strict qw(refs);
	
	my $class = shift;
	my ($name, $value, $globals) = @_;
	my $tags  = \%{"$class\::EXPORT_TAGS"};
	
	return $class->_exporter_merge_opts($value, $globals, $tags->{$name}->($class, @_))
		if ref($tags->{$name}) eq q(CODE);