File Coverage

blib/lib/Type/Params/Parameter.pm

Criterion	Covered	Total	%
statement	196	200	98.0
branch	104	110	94.5
condition	64	77	83.1
subroutine	30	31	96.7
pod	18	19	94.7
total	412	437	94.2

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.010001';
}

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

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

my $RE_WORDLIKE = qr/\A[^\W0-9]\w*\z/;

my $Attrs = Enum[ qw/
	name type slurpy default alias strictness coerce clone in_list optional
	getter predicate allow_dash vartail default_on_undef
	quux
/ ];

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} ];
	}

	my $self = bless \%self, $class;

	$Attrs->all( sort keys %$self ) or do {
		require Carp;
		require Type::Utils;
		my @bad = ( ~ $Attrs )->grep( sort keys %$self );
		Carp::carp( sprintf(
			"Warning: unrecognized parameter %s: %s, continuing anyway",
			@bad == 1 ? 'option' : 'options',
			Type::Utils::english_list( @bad ),
		) );
	};

	return $self;
}

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 default_on_undef { $_[0]{default_on_undef} }

sub in_list {
	return $_[0]{in_list} if exists $_[0]{in_list};
	$_[0]{in_list} = !$_[0]->optional;
}

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, $_[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 _all_aliases {
	my ( $self, $signature ) = @_;
	my $allow_dash = $self->{allow_dash};
	$allow_dash = $signature->allow_dash if !defined $allow_dash;
	my @aliases;
	if ( $allow_dash and $self->name =~ $RE_WORDLIKE ) {
		push @aliases, sprintf( '-%s', $self->name );
	}
	for my $name ( @{ $self->alias } ) {
		push @aliases, $name;
		if ( $allow_dash and $name =~ $RE_WORDLIKE ) {
			push @aliases, sprintf( '-%s', $name );
		}
	}
	return @aliases;
}

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;

	# Allow Optional itself, without any parameter.
	$really_optional = Types::Standard::Any
		if $constraint && $constraint->{uniq} eq Optional->{uniq};

	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 my @aliases = $self->_all_aliases($signature) ) {
		$coderef->add_line( sprintf(
			'for my $alias ( %s ) {',
			join( q{, }, map B::perlstring($_), @aliases ),
		) );
		$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 ( $args{is_named} and $signature->list_to_named and $self->in_list ) {
		$coderef->addf( 'if ( not exists %s ) {', $varname );
		$coderef->increase_indent;
		$coderef->addf( 'for my $ix ( 0 .. $#positional ) {' );
		$coderef->increase_indent;
		$coderef->addf( '%s or next;', ( $really_optional or $constraint )->coercibles->inline_check( '$positional[$ix]' ) );
		$coderef->addf( '( %s ) = splice( @positional, $ix, 1 );', $varname );
		$coderef->addf( 'last;' );
		$coderef->decrease_indent;
		$coderef->addf( '}' );
		$coderef->decrease_indent;
		$coderef->addf( '}' );
	}

	if ( $self->has_default ) {
		my $check = $exists_check;
		if ( $self->default_on_undef ) {
			$check = "( $check and defined $varname )";
		}
		$self->{vartail} = $vartail; # hack
		$coderef->add_line( sprintf(
			'$dtmp = %s ? %s : %s;',
			$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 ( $args{is_slurpy} and $self->_dont_validate_slurpy ) {
		$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;
}

# This list can be reused safely.
my @uniqs;

# If $SLURPY is one of a handful of very loose type constraints, there is
# no need to validate it because we built it as a hashref or arrayref ourself,
# so there's no way it couldn't be a hashref or arrayref.
sub _dont_validate_slurpy {
	my $self = shift;
	my $type = $self->type or return 1;
	if ( not @uniqs ) {
		@uniqs = map { $_->{uniq} }
			Slurpy,
			Slurpy[Any],      Any,
			Slurpy[Item],     Item,
			Slurpy[Ref],      Ref,
			Slurpy[HashRef],  HashRef,
			Slurpy[ArrayRef], ArrayRef;
	}
	( $_ == $type->{uniq} and return 1 ) for @uniqs;
	return 0;
}

1;

__END__