File Coverage

blib/lib/Type/Params/Alternatives.pm

Criterion	Covered	Total	%
statement	102	105	97.1
branch	32	36	88.8
condition	19	28	67.8
subroutine	26	27	96.3
pod	11	11	100.0
total	190	207	91.7

package Type::Params::Alternatives;

use 5.008001;
use strict;
use warnings;

BEGIN {
	if ( $] < 5.010 ) { require Devel::TypeTiny::Perl58Compat }
}

BEGIN {
	$Type::Params::Alternatives::AUTHORITY  = 'cpan:TOBYINK';
	$Type::Params::Alternatives::VERSION    = '2.010001';
}

$Type::Params::Alternatives::VERSION =~ tr/_//d;

use B ();
use Eval::TypeTiny::CodeAccumulator;
use Types::Standard qw( -is -types -assert );
use Types::TypeTiny qw( -is -types to_TypeTiny );

my $Attrs = Enum[ qw/
	caller_level package subname description _is_signature_for ID
	method head tail parameters slurpy
	message on_die next fallback strictness is_named allow_dash method_invocant
	bless class constructor named_to_list list_to_named oo_trace
	class_prefix class_attributes
	returns_scalar returns_list
	want_details want_object want_source can_shortcut coderef

	sig_class base_options alternatives meta_alternatives

	quux mite_signature is_wrapper
/ ]; # quux for reasons

require Type::Params::Signature;
our @ISA = 'Type::Params::Signature';

sub new {
	my $class = shift;
	my %self  = @_ == 1 ? %{$_[0]} : @_;
	my $self = bless \%self, $class;
	$self->{next} ||= delete $self->{goto_next} if exists $self->{goto_next};
	exists( $self->{$_} ) || ( $self->{$_} = $self->{base_options}{$_} )
		for keys %{ $self->{base_options} };
	$self->{sig_class} ||= 'Type::Params::Signature';
	$self->{message}   ||= 'Parameter validation failed';
	delete $self->{base_options}{$_} for qw/ returns returns_list returns_scalar /;
	$self->_rationalize_returns;
	$Attrs->all( sort keys %$self ) or do {
		require Carp;
		require Type::Utils;
		my @bad = ( ~ $Attrs )->grep( sort keys %$self );
		Carp::carp( sprintf(
			"Warning: unrecognized signature %s: %s, continuing anyway",
			@bad == 1 ? 'option' : 'options',
			Type::Utils::english_list( @bad ),
		) );
	};
	return $self;
}

sub base_options      { $_[0]{base_options}      ||= {} }
sub alternatives      { $_[0]{alternatives}      ||= [] }
sub sig_class         { $_[0]{sig_class} }
sub meta_alternatives { $_[0]{meta_alternatives} ||= $_[0]->_build_meta_alternatives }
sub parameters        { [] }
sub next              { $_[0]{base_options}{next} }
sub goto_next         { $_[0]{base_options}{next} }
sub package           { $_[0]{base_options}{package}   }
sub subname           { $_[0]{base_options}{subname}   }

sub _build_meta_alternatives {
	my $self = shift;

	my $index = 0;
	return [
		map {
			$self->_build_meta_alternative( $_, $index++ )
		} @{ $self->alternatives }
	];
}

sub _build_meta_alternative {
	my ( $self, $alt, $index ) = @_;

	my $meta;
	if ( is_CodeRef $alt ) {
		$meta = { closure => $alt };
	}
	elsif ( is_HashRef $alt and exists $alt->{closure} ) {
		$meta = { %$alt };
	}
	elsif ( is_HashRef $alt ) {
		my %opts = (
			%{ $self->base_options },
			next            => !!0, # don't propagate these next few
			returns         => undef,
			returns_scalar  => undef,
			returns_list    => undef,
			%$alt,
			want_source     => !!0,
			want_object     => !!0,
			want_details    => !!1,
		);
		$meta = $self->sig_class->new_from_v2api( \%opts )->return_wanted;
		$meta->{ID} = $alt->{ID} if exists $alt->{ID};
	}
	elsif ( is_ArrayRef $alt ) {
		my %opts = (
			%{ $self->base_options },
			next            => !!0, # don't propagate these next few
			returns         => undef,
			returns_scalar  => undef,
			returns_list    => undef,
			positional      => $alt,
			want_source     => !!0,
			want_object     => !!0,
			want_details    => !!1,
		);
		$meta = $self->sig_class->new_from_v2api( \%opts )->return_wanted;
	}
	else {
		$self->_croak( 'Alternative signatures must be CODE, HASH, or ARRAY refs' );
	}

	$meta->{_index} = $index;
	return $meta;
}

sub _coderef_start_extra {
	my ( $self, $coderef ) = ( shift, @_ );

	$coderef->add_line( 'my $r;' );
	$coderef->add_line( 'undef ${^_TYPE_PARAMS_MULTISIG};' );
	$coderef->add_gap;

	for my $meta ( @{ $self->meta_alternatives } ) {
		$self->_coderef_meta_alternative( $coderef, $meta );
	}

	$self;
}

sub _coderef_meta_alternative {
	my ( $self, $coderef, $meta ) = ( shift, @_ );

	my @cond = '! $r';
	push @cond, sprintf( '@_ >= %s', $meta->{min_args} ) if defined $meta->{min_args};
	push @cond, sprintf( '@_ <= %s', $meta->{max_args} ) if defined $meta->{max_args};
	if ( defined $meta->{max_args} and defined $meta->{min_args} ) {
		splice @cond, -2, 2, sprintf( '@_ == %s', $meta->{min_args} )
			if $meta->{max_args} == $meta->{min_args};
	}

	# It is sometimes possible to inline $meta->{source} here
	if ( $meta->{source}
	and $meta->{source} !~ /return/
	and ! keys %{ $meta->{environment} } ) {

		my $alt_code = $meta->{source};
		$alt_code =~ s/^sub [{]/do {/;
		$coderef->add_line( sprintf(
			'eval { local @_ = @_; $r = [ %s ]; ${^_TYPE_PARAMS_MULTISIG} = %s }%sif ( %s );',
			$alt_code,
			defined( $meta->{ID} )
				? B::perlstring( $meta->{ID} )
				: ( 0 + $meta->{_index} ),
			"\n\t",
			join( ' and ', @cond ),
		) );
		$coderef->add_gap;
	}
	else {

		my $callback_var = $coderef->add_variable( '$signature', \$meta->{closure} );
		$coderef->add_line( sprintf(
			'eval { $r = [ %s->(@_) ]; ${^_TYPE_PARAMS_MULTISIG} = %s }%sif ( %s );',
			$callback_var,
			defined( $meta->{ID} )
				? B::perlstring( $meta->{ID} )
				: ( 0 + $meta->{_index} ),
			"\n\t",
			join( ' and ', @cond ),
		) );
		$coderef->add_gap;
	}

	return $self;
}

sub _coderef_end_extra {
	my ( $self, $coderef ) = ( shift, @_ );

	$coderef->add_line( sprintf(
		'%s unless $r;',
		$self->_make_general_fail( message => B::perlstring( $self->{message} ) ),
	) );
	$coderef->add_gap;

	return $self;
}

sub _coderef_check_count {
	shift;
}

sub _make_return_list {
	'@$r';
}

sub make_class_pp_code {
	my $self = shift;

	return join(
		qq{\n},
		grep { length $_ }
		map  { $_->{class_definition} || '' }
		@{ $self->meta_alternatives }
	);
}

1;

__END__