File Coverage

blib/lib/Type/Params/Parameter.pm

Criterion	Covered	Total	%
statement	154	156	98.7
branch	82	86	95.3
condition	46	54	85.1
subroutine	27	27	100.0
pod	0	17	0.0
total	309	340	90.8

# INTERNAL MODULE: a parameter within a Type::Params::Signature.

package Type::Params::Parameter;

use 5.008001;
use strict;
use warnings;

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

BEGIN {
	$Type::Params::Parameter::AUTHORITY  = 'cpan:TOBYINK';
	$Type::Params::Parameter::VERSION    = '2.002001';
}

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

use Types::Standard qw( -is -types );

sub _croak {
	require Carp;
	Carp::croak( pop );
}

sub new {
	my $class = shift;

	my %self  = @_ == 1 ? %{$_[0]} : @_;
	$self{alias} ||= [];
	if ( defined $self{alias} and not ref $self{alias} ) {
		$self{alias} = [ $self{alias} ];
	}

	bless \%self, $class;
}

sub name       { $_[0]{name} }        sub has_name       { exists $_[0]{name} }
sub type       { $_[0]{type} }        sub has_type       { exists $_[0]{type} }
sub default    { $_[0]{default} }     sub has_default    { exists $_[0]{default} }
sub alias      { $_[0]{alias} }       sub has_alias      { @{ $_[0]{alias} } }
sub strictness { $_[0]{strictness} }  sub has_strictness { exists $_[0]{strictness} }

sub should_clone { $_[0]{clone} }

sub coerce  {
	exists( $_[0]{coerce} )
		? $_[0]{coerce}
		: ( $_[0]{coerce} = $_[0]->type->has_coercion )
}

sub optional  {
	exists( $_[0]{optional} )
		? $_[0]{optional}
		: do {
			$_[0]{optional} = $_[0]->has_default || grep(
				$_->{uniq} == Optional->{uniq},
				$_[0]->type->parents,
			);
		}
}

sub getter  {
	exists( $_[0]{getter} )
		? $_[0]{getter}
		: ( $_[0]{getter} = $_[0]{name} )
}

sub predicate  {
	exists( $_[0]{predicate} )
		? $_[0]{predicate}
		: ( $_[0]{predicate} = ( $_[0]->optional ? 'has_' . $_[0]{name} : undef ) )
}

sub might_supply_new_value {
	$_[0]->has_default or $_[0]->coerce or $_[0]->should_clone;
}

sub _code_for_default {
	my ( $self, $signature, $coderef ) = @_;
	my $default = $self->default;

	if ( is_CodeRef $default ) {
		my $default_varname = $coderef->add_variable(
			'$default_for_' . $self->{vartail},
			\$default,
		);
		return sprintf( '%s->( %s )', $default_varname, $signature->method_invocant );
	}
	if ( is_Undef $default ) {
		return 'undef';
	}
	if ( is_Str $default ) {
		return B::perlstring( $default );
	}
	if ( is_HashRef $default ) {
		return '{}';
	}
	if ( is_ArrayRef $default ) {
		return '[]';
	}
	if ( is_ScalarRef $default ) {
		return $$default;
	}

	$self->_croak( 'Default expected to be undef, string, coderef, or empty arrayref/hashref' );
}

sub _maybe_clone {
	my ( $self, $varname ) = @_;

	if ( $self->should_clone ) {
		return sprintf( 'Storable::dclone( %s )', $varname );
	}
	return $varname;
}

sub _make_code {
	my ( $self, %args ) = ( shift, @_ );

	my $type        = $args{type} || 'arg';
	my $signature   = $args{signature};
	my $coderef     = $args{coderef};
	my $varname     = $args{input_slot};
	my $index       = $args{index};
	my $constraint  = $self->type;
	my $is_optional = $self->optional;
	my $really_optional =
		$is_optional
		&& $constraint->parent
		&& $constraint->parent->{uniq} eq Optional->{uniq}
		&& $constraint->type_parameter;

	my $strictness;
	if ( $self->has_strictness ) {
		$strictness = \ $self->strictness;
	}
	elsif ( $signature->has_strictness ) {
		$strictness = \ $signature->strictness;
	}

	my ( $vartail, $exists_check );
	if ( $args{is_named} ) {
		my $bit = $args{key};
		$bit =~ s/([_\W])/$1 eq '_' ? '__' : sprintf('_%x', ord($1))/ge;
		$vartail = $type . '_' . $bit;
		$exists_check = sprintf 'exists( %s )', $args{input_slot};
	}
	else {
		( my $input_count_varname = $args{input_var} || '' ) =~ s/\@/\$\#/;
		$vartail = $type . '_' . $index;
		$exists_check = sprintf '%s >= %d', $input_count_varname, $index;
	}

	my $block_needs_ending = 0;
	my $needs_clone = $self->should_clone;
	my $in_big_optional_block = 0;

	if ( $needs_clone and not $signature->{loaded_Storable} ) {
		$coderef->add_line( 'use Storable ();' );
		$coderef->add_gap;
		$signature->{loaded_Storable} = 1;
	}

	$coderef->add_line( sprintf(
		'# Parameter %s (type: %s)',
		$self->name || $args{input_slot},
		$constraint->display_name,
	) );

	if ( $args{is_named} and $self->has_alias ) {
		$coderef->add_line( sprintf(
			'for my $alias ( %s ) {',
			join( q{, }, map B::perlstring($_), @{ $self->alias } ),
		) );
		$coderef->increase_indent;
		$coderef->add_line( 'exists $in{$alias} or next;' );
		$coderef->add_line( sprintf(
			'if ( %s ) {',
			$exists_check,
		) );
		$coderef->increase_indent;
		$coderef->add_line( sprintf(
			'%s;',
			$signature->_make_general_fail(
				coderef  => $coderef,
				message  => q{sprintf( 'Superfluous alias "%s" for argument "%s"', $alias, } . B::perlstring( $self->name || $args{input_slot} ) . q{ )},
			),
		) );
		$coderef->decrease_indent;
		$coderef->add_line( '}' );
		$coderef->add_line( 'else {' );
		$coderef->increase_indent;
		$coderef->add_line( sprintf(
			'%s = delete( $in{$alias} );',
			$varname,
		) );
		$coderef->decrease_indent;
		$coderef->add_line( '}' );
		$coderef->decrease_indent;
		$coderef->add_line( '}' );
	}

	if ( $self->has_default ) {
		$self->{vartail} = $vartail; # hack
		$coderef->add_line( sprintf(
			'$dtmp = %s ? %s : %s;',
			$exists_check,
			$self->_maybe_clone( $varname ),
			$self->_code_for_default( $signature, $coderef ),
		) );
		$varname = '$dtmp';
		$needs_clone = 0;
	}
	elsif ( $self->optional ) {
		if ( $args{is_named} ) {
			$coderef->add_line( sprintf(
				'if ( %s ) {',
				$exists_check,
			) );
			$coderef->{indent} .= "\t";
			++$block_needs_ending;
			++$in_big_optional_block;
		}
		else {
			$coderef->add_line( sprintf(
				"%s\n\tor %s;",
				$exists_check,
				$signature->_make_return_expression( is_early => 1 ),
			) );
		}
	}
	elsif ( $args{is_named} ) {
		$coderef->add_line( sprintf(
			"%s\n\tor %s;",
			$exists_check,
			$signature->_make_general_fail(
				coderef => $coderef,
				message => "'Missing required parameter: $args{key}'",
			),
		) );
	}

	if ( $needs_clone ) {
		$coderef->add_line( sprintf(
			'$dtmp = %s;',
			$self->_maybe_clone( $varname ),
		) );
		$varname = '$dtmp';
		$needs_clone = 0;
	}

	if ( $constraint->has_coercion and $constraint->coercion->can_be_inlined ) {
		$coderef->add_line( sprintf(
			'$tmp%s = %s;',
			( $is_optional ? '{x}' : '' ),
			$constraint->coercion->inline_coercion( $varname )
		) );
		$varname = '$tmp' . ( $is_optional ? '{x}' : '' );
	}
	elsif ( $constraint->has_coercion ) {
		my $coercion_varname = $coderef->add_variable(
			'$coercion_for_' . $vartail,
			\ $constraint->coercion->compiled_coercion,
		);
		$coderef->add_line( sprintf(
			'$tmp%s = &%s( %s );',
			( $is_optional ? '{x}' : '' ),
			$coercion_varname,
			$varname,
		) );
		$varname = '$tmp' . ( $is_optional ? '{x}' : '' );
	}

	undef $Type::Tiny::ALL_TYPES{ $constraint->{uniq} };
	$Type::Tiny::ALL_TYPES{ $constraint->{uniq} } = $constraint;

	my $strictness_test = '';
	if ( $strictness and $$strictness eq 1 ) {
		$strictness_test = '';
	}
	elsif ( $strictness and $$strictness ) {
		$strictness_test = sprintf "( not %s )\n\tor ", $$strictness;
	}

	if ( $strictness and not $$strictness ) {
		$coderef->add_line( '1; # ... nothing to do' );
	}
	elsif ( $constraint->{uniq} == Any->{uniq} ) {
		$coderef->add_line( '1; # ... nothing to do' );
	}
	elsif ( $constraint->can_be_inlined ) {
		$coderef->add_line( $strictness_test . sprintf(
			"%s\n\tor %s;",
			( $really_optional or $constraint )->inline_check( $varname ),
			$signature->_make_constraint_fail(
				coderef      => $coderef,
				parameter    => $self,
				constraint   => $constraint,
				varname      => $varname,
				display_var  => $args{display_var},
			),
		) );
	}
	else {
		my $compiled_check_varname = $coderef->add_variable(
			'$check_for_' . $vartail,
			\ ( ( $really_optional or $constraint )->compiled_check ),
		);
		$coderef->add_line( $strictness_test . sprintf(
			"&%s( %s )\n\tor %s;",
			$compiled_check_varname,
			$varname,
			$signature->_make_constraint_fail(
				coderef      => $coderef,
				parameter    => $self,
				constraint   => $constraint,
				varname      => $varname,
				display_var  => $args{display_var},
			),
		) );
	}

	if ( $args{output_var} ) {
		$coderef->add_line( sprintf(
			'push( %s, %s );',
			$args{output_var},
			$varname,
		) );
	}
	elsif ( $args{output_slot} and $args{output_slot} ne $varname ) {
		if ( !$in_big_optional_block and $varname =~ /\{/ ) {
			$coderef->add_line( sprintf(
				'%s = %s if exists( %s );',
				$args{output_slot},
				$varname,
				$varname,
			) );
		}
		else {
			$coderef->add_line( sprintf(
				'%s = %s;',
				$args{output_slot},
				$varname,
			) );
		}
	}

	if ( $args{is_named} ) {
		$coderef->add_line( sprintf(
			'delete( %s );',
			$args{input_slot},
		) );
	}

	if ( $block_needs_ending ) {
		$coderef->{indent} =~ s/\s$//;
		$coderef->add_line( '}' );
	}

	$coderef->add_gap;

	$self;
}

1;