view release on metacpan or  search on metacpan

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

package Eval::TypeTiny;

use strict;

sub _clean_eval {
	local $@;
	local $SIG{__DIE__};
	my $r = eval $_[0];
	my $e = $@;
	return ( $r, $e );
}

use warnings;

BEGIN {
	*HAS_LEXICAL_SUBS = ( $] >= 5.018 ) ? sub () { !!1 } : sub () { !!0 };
	*NICE_PROTOTYPES  = ( $] >= 5.014 ) ? sub () { !!1 } : sub () { !!0 };
}

sub _pick_alternative {
	my $ok = 0;
	while ( @_ ) {
		my ( $type, $condition, $result ) = splice @_, 0, 3;
		if ( $type eq 'needs' ) {
			++$ok if eval "require $condition; 1";
		}
		elsif ( $type eq 'if' ) {
			++$ok if $condition;
		}
		next unless $ok;
		return ref( $result ) eq 'CODE' ? $result->() : ref( $result ) eq 'SCALAR' ? eval( $$result ) : $result;
	}
	return;
}

{
	sub IMPLEMENTATION_DEVEL_LEXALIAS () { 'Devel::LexAlias' }
	sub IMPLEMENTATION_PADWALKER ()      { 'PadWalker' }
	sub IMPLEMENTATION_TIE ()            { 'tie' }
	sub IMPLEMENTATION_NATIVE ()         { 'perl' }
	
	my $implementation;
	
	#<<<
	# uncoverable subroutine
	sub ALIAS_IMPLEMENTATION () {
		$implementation ||= _pick_alternative(
			if    => ( $] ge '5.022' ) => IMPLEMENTATION_NATIVE,
			needs => 'Devel::LexAlias' => IMPLEMENTATION_DEVEL_LEXALIAS,
			needs => 'PadWalker'       => IMPLEMENTATION_PADWALKER,
			if    => !!1               => IMPLEMENTATION_TIE,
		);
	}
	#>>>
	
	sub _force_implementation {
		$implementation = shift;
	}
}

BEGIN {
	*_EXTENDED_TESTING = $ENV{EXTENDED_TESTING} ? sub() { !!1 } : sub() { !!0 };
}

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '2.010001';
our @EXPORT    = qw( eval_closure );
our @EXPORT_OK = qw(
	HAS_LEXICAL_SUBS HAS_LEXICAL_VARS ALIAS_IMPLEMENTATION
	IMPLEMENTATION_DEVEL_LEXALIAS IMPLEMENTATION_PADWALKER
	IMPLEMENTATION_NATIVE IMPLEMENTATION_TIE
	set_subname type_to_coderef NICE_PROTOTYPES
);

$VERSION =~ tr/_//d;

# See Types::TypeTiny for an explanation of this import method.
#
# uncoverable subroutine
sub import {
	no warnings "redefine";
	our @ISA = qw( Exporter::Tiny );
	require Exporter::Tiny;
	my $next = \&Exporter::Tiny::import;
	*import = $next;
	my $class = shift;
	my $opts  = { ref( $_[0] ) ? %{ +shift } : () };
	$opts->{into} ||= scalar( caller );
	return $class->$next( $opts, @_ );
} #/ sub import

{
	my $subname;
	my %already;    # prevent renaming established functions
	sub set_subname ($$) {
		$subname = _pick_alternative(
			needs => 'Sub::Util' => \ q{ \&Sub::Util::set_subname },
			needs => 'Sub::Name' => \ q{ \&Sub::Name::subname     },
			if    => !!1         => 0,
		) unless defined $subname;
		$subname and !$already{$_[1]}++ and return &$subname;
		$_[1];
	} #/ sub set_subname ($$)
}

sub type_to_coderef {
	my ( $type, %args ) = @_;
	my $post_method = $args{post_method} || q();