view release on metacpan or  search on metacpan

lib/Eval/TypeTiny.pm  view on Meta::CPAN

	my ( $key, $index, $alias ) = @_;
	my $name = substr( $key, 1 );
	
	if ( HAS_LEXICAL_SUBS and $key =~ /^\&/ ) {
		$tmp++;
		my $tmpname = '$__LEXICAL_SUB__' . $tmp;
		return
			"no warnings 'experimental::lexical_subs';"
			. "use feature 'lexical_subs';"
			. "my $tmpname = \$_[$index];"
			. "my sub $name { goto $tmpname };";
	}
	
	if ( !$alias ) {
		my $sigil = substr( $key, 0, 1 );
		return "my $key = $sigil\{ \$_[$index] };";
	}
	elsif ( ALIAS_IMPLEMENTATION eq IMPLEMENTATION_NATIVE ) {
		return
			"no warnings 'experimental::refaliasing';"
			. "use feature 'refaliasing';"
			. "my $key; \\$key = \$_[$index];";
	}
	elsif ( ALIAS_IMPLEMENTATION eq IMPLEMENTATION_DEVEL_LEXALIAS ) {
		return "my $key;";
	}
	elsif ( ALIAS_IMPLEMENTATION eq IMPLEMENTATION_PADWALKER ) {
		return "my $key;";
	}
	else {
		my $tieclass = {
			'@' => 'Eval::TypeTiny::_TieArray',
			'%' => 'Eval::TypeTiny::_TieHash',
			'$' => 'Eval::TypeTiny::_TieScalar',
		}->{ substr( $key, 0, 1 ) };
		
		return sprintf(
			'tie(my(%s), "%s", $_[%d]);',
			$key,
			$tieclass,
			$index,
		);
	} #/ else [ if ( !$alias ) ]
} #/ sub _make_lexical_assignment

{
	my $tie;
	
	sub _manufacture_ties {
		$tie ||= eval <<'FALLBACK'; } }
no warnings qw(void once uninitialized numeric);
use Type::Tiny ();

{
	package #
		Eval::TypeTiny::_TieArray;
	require Tie::Array;
	our @ISA = qw( Tie::StdArray );
	sub TIEARRAY {
		my $class = shift;
		bless $_[0] => $class;
	}
	sub AUTOLOAD {
		my $self = shift;
		my ($method) = (our $AUTOLOAD =~ /(\w+)$/);
		defined tied(@$self) and return tied(@$self)->$method(@_);
		require Carp;
		Carp::croak(qq[Can't call method "$method" on an undefined value]) unless $method eq 'DESTROY';
	}
	sub can {
		my $self = shift;
		my $code = $self->SUPER::can(@_)
			|| (defined tied(@$self) and tied(@$self)->can(@_));
		return $code;
	}
	__PACKAGE__->Type::Tiny::_install_overloads(
		q[bool]  => sub { !!   tied @{$_[0]} },
		q[""]    => sub { '' . tied @{$_[0]} },
		q[0+]    => sub { 0  + tied @{$_[0]} },
	);
}
{
	package #
		Eval::TypeTiny::_TieHash;
	require Tie::Hash;
	our @ISA = qw( Tie::StdHash );
	sub TIEHASH {
		my $class = shift;
		bless $_[0] => $class;
	}
	sub AUTOLOAD {
		my $self = shift;
		my ($method) = (our $AUTOLOAD =~ /(\w+)$/);
		defined tied(%$self) and return tied(%$self)->$method(@_);
		require Carp;
		Carp::croak(qq[Can't call method "$method" on an undefined value]) unless $method eq 'DESTROY';
	}
	sub can {
		my $self = shift;
		my $code = $self->SUPER::can(@_)
			|| (defined tied(%$self) and tied(%$self)->can(@_));
		return $code;
	}
	__PACKAGE__->Type::Tiny::_install_overloads(
		q[bool]  => sub { !!   tied %{$_[0]} },
		q[""]    => sub { '' . tied %{$_[0]} },
		q[0+]    => sub { 0  + tied %{$_[0]} },
	);
}
{
	package #
		Eval::TypeTiny::_TieScalar;
	require Tie::Scalar;
	our @ISA = qw( Tie::StdScalar );
	sub TIESCALAR {
		my $class = shift;
		bless $_[0] => $class;
	}
	sub AUTOLOAD {
		my $self = shift;
		my ($method) = (our $AUTOLOAD =~ /(\w+)$/);
		defined tied($$self) and return tied($$self)->$method(@_);
		require Carp;
		Carp::croak(qq[Can't call method "$method" on an undefined value]) unless $method eq 'DESTROY';
	}
	sub can {
		my $self = shift;
		my $code = $self->SUPER::can(@_)
			|| (defined tied($$self) and tied($$self)->can(@_));
		return $code;
	}
	__PACKAGE__->Type::Tiny::_install_overloads(
		q[bool]  => sub { !!   tied ${$_[0]} },
		q[""]    => sub { '' . tied ${$_[0]} },
		q[0+]    => sub { 0  + tied ${$_[0]} },
	);
}

1;
FALLBACK

1;

__END__

=pod

=encoding utf-8

=for stopwords pragmas coderefs

=head1 NAME

Eval::TypeTiny - utility to evaluate a string of Perl code in a clean environment

=head1 STATUS
 
This module is covered by the
L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">.

=head1 DESCRIPTION

This module is used by Type::Tiny to compile coderefs from strings of
Perl code, and hashrefs of variables to close over.

=head2 Functions

By default this module exports one function, which works much like the
similarly named function from L<Eval::Closure>:

=over

=item C<< eval_closure(source => $source, environment => \%env, %opt) >>

=back

Other functions can be imported on request: