view release on metacpan or  search on metacpan

lib/Acme/Constructor/Pythonic.pm  view on Meta::CPAN

BEGIN {
	$Acme::Constructor::Pythonic::AUTHORITY = 'cpan:TOBYINK';
	$Acme::Constructor::Pythonic::VERSION   = '0.002';
	@Acme::Constructor::Pythonic::ISA       = qw( Exporter::Tiny );
}

sub import
{
	my $me      = shift;
	my $globals = ref($_[0]) eq 'HASH' ? shift() : {};
	
	unless (ref($globals->{into}))
	{
		my @caller = caller;
		$globals->{into_file} = $caller[1] unless exists $globals->{into_file};
		$globals->{into_line} = $caller[2] unless exists $globals->{into_line};
	}
	
	unshift @_, $me, $globals;
	goto \&Exporter::Tiny::import;
}

my %_CACHE;
sub _exporter_expand_sub
{
	my $me = shift;
	my ($name, $args, $globals) = @_;
	
	# We want to be invisible to Carp
	$Carp::Internal{$me} = 1;
	
	# Process incoming arguments, providing sensible defaults.
	my $module = $name;
	my $class  = defined($args->{class})       ? $args->{class}       : $name;
	my $ctor   = defined($args->{constructor}) ? $args->{constructor} : 'new';
	my $alias  = defined($args->{alias})       ? $args->{alias}       : $name;
	my $req    = exists($args->{no_require})   ? !$args->{no_require} : !$globals->{no_require};
	
	# Doesn't really make sense to include a package name
	# as part of the alias. We were just lazy in initializing
	# the default above.
	$alias = $1 if $alias =~ /::(\w+)\z/;
	
	# We really only need Module::Runtime if $req is on.
	# $req is on by default, but in imagined case where
	# the caller has been diligent enough to no_require
	# every import, we can do them a favour and not
	# needlessly load Module::Runtime into memory.
	if ($req) { require Module::Runtime }
	
	# Compile a custom coderef instead of closing
	# over variables.
	my $code = join("\n",
		sprintf('package %s;', $me),
		defined($globals->{into_line}) && defined($globals->{into_file})
			? sprintf('#line %d "%s"', @$globals{qw(into_line into_file)})
			: (),
		sprintf('sub {'),
		$req
			? sprintf('Module::Runtime::use_module(qq[%s]);', quotemeta($module))
			: (),
		sprintf('qq[%s]->%s(@_);', quotemeta($class), $ctor),
		sprintf('}'),
	);
	
	# Orcish maneuver