File Coverage

blib/lib/Type/Params.pm

Criterion	Covered	Total	%
statement	200	200	100.0
branch	65	74	87.8
condition	39	63	61.9
subroutine	46	47	97.8
pod	14	14	100.0
total	364	398	91.4

package Type::Params;

use 5.008001;
use strict;
use warnings;

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

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

use B qw();
use Eval::TypeTiny qw( eval_closure set_subname );
use Scalar::Util qw( refaddr );
use Error::TypeTiny;
use Error::TypeTiny::Assertion;
use Error::TypeTiny::WrongNumberOfParameters;
use Types::Standard ();
use Types::TypeTiny ();

require Exporter::Tiny;
our @ISA = 'Exporter::Tiny';

our @EXPORT = qw(
	compile compile_named
);

our @EXPORT_OK = qw(
	compile_named_oo
	validate validate_named
	multisig
	Invocant ArgsObject
	wrap_subs wrap_methods
	signature signature_for signature_for_func signature_for_method
);

our %EXPORT_TAGS = (
	compile  => [ qw( compile compile_named compile_named_oo ) ],
	wrap     => [ qw( wrap_subs wrap_methods ) ],
	sigs     => [ qw( signature signature_for ) ],
	validate => [ qw( validate validate_named ) ],
	sigplus  => [ qw( signature signature_for signature_for_func signature_for_method ) ],

	v1       => [ qw( compile compile_named ) ],      # Old default
	v2       => [ qw( signature signature_for ) ],    # New recommendation
);

BEGIN {
	my $pfx = $ENV{'PERL_TYPE_PARAMS_SUBNAME_PREFIX'};
	eval sprintf(
		'sub SIGNATURE_SUBNAME_PREFIX () { %s }',
		B::perlstring(
			( defined $pfx and $pfx =~ /::\z/ ) ? $pfx : $pfx ? 'SIGNATURE_FOR::' : '',
		)
	);

	my $sfx = $ENV{'PERL_TYPE_PARAMS_SUBNAME_SUFFIX'};
	eval sprintf(
		'sub SIGNATURE_SUBNAME_SUFFIX () { %s }',
		B::perlstring(
			( defined $sfx and $sfx =~ /\A_/ ) ? $sfx : $sfx ? '_SIGNATURE' : '',
		)
	);
};

{
	my $Invocant;

	sub Invocant () {
		$Invocant ||= do {
			require Type::Tiny::Union;
			'Type::Tiny::Union'->new(
				name             => 'Invocant',
				type_constraints => [
					Types::Standard::Object(),
					Types::Standard::ClassName(),
				],
			);
		};
	} #/ sub Invocant

	my $ArgsObject;

	sub ArgsObject (;@) {
		$ArgsObject ||= do {
			'Type::Tiny'->new(
				name                 => 'ArgsObject',
				parent               => Types::Standard::Object(),
				constraint           => q{ ref($_) =~ qr/^Type::Params::OO::/ },
				constraint_generator => sub {
					Type::Tiny::check_parameter_count_for_parameterized_type( 'Type::Params', 'ArgsObject', \@_, 1, 1 );
					my $param = Types::Standard::assert_Str( shift );
					sub { defined( $_->{'~~caller'} ) and $_->{'~~caller'} eq $param };
				},
				inline_generator => sub {
					my $param  = shift;
					my $quoted = B::perlstring( $param );
					sub {
						my $var = pop;
						return (
							Types::Standard::Object()->inline_check( $var ),
							sprintf( q{ ref(%s) =~ qr/^Type::Params::OO::/ }, $var ),
							sprintf(
								q{ do { use Scalar::Util (); Scalar::Util::reftype(%s) eq 'HASH' } }, $var
							),
							sprintf(
								q{ defined((%s)->{'~~caller'}) && ((%s)->{'~~caller'} eq %s) }, $var, $var,
								$quoted
							),
						);
					};
				},
			);
		};

		@_ ? $ArgsObject->parameterize( @{ $_[0] } ) : $ArgsObject;
	} #/ sub ArgsObject (;@)

	&Scalar::Util::set_prototype( \&ArgsObject, ';$' )
		if Eval::TypeTiny::NICE_PROTOTYPES;
}

sub signature {
	if ( @_ % 2 ) {
		require Error::TypeTiny;
		Error::TypeTiny::croak( "Expected even-sized list of arguments" );
	}
	my ( %opts ) = @_;
	$opts{next} ||= delete $opts{goto_next} if exists $opts{goto_next};

	my $for = [ caller( 1 + ( $opts{caller_level} || 0 ) ) ]->[3] || ( ( $opts{package} || '__ANON__' ) . '::__ANON__' );
	my ( $pkg, $sub ) = ( $for =~ /^(.+)::(\w+)$/ );
	$opts{package} ||= $pkg;
	$opts{subname} ||= $sub;

	require Type::Params::Signature;
	'Type::Params::Signature'->new_from_v2api( \%opts )->return_wanted;
}

sub signature_for {
	if ( not @_ % 2 ) {
		require Error::TypeTiny;
		Error::TypeTiny::croak( "Expected odd-sized list of arguments; did you forget the function name?" );
	}
	my ( $function, %opts ) = @_;
	my $package = $opts{package} || caller( $opts{caller_level} || 0 );
	$opts{next} ||= delete $opts{goto_next} if exists $opts{goto_next};

	if ( ref($function) eq 'ARRAY' ) {
		$opts{package} = $package;
		return map { signature_for( $_, %opts ) } @$function;
	}

	$opts{_is_signature_for} = 1;

	my $fullname = ( $function =~ /::/ ) ? $function : "$package\::$function";
	$opts{package}   ||= $package;
	$opts{subname}   ||= ( $function =~ /::(\w+)$/ ) ? $1 : $function;
	$opts{next}      ||= do { no strict 'refs'; exists(&$fullname) ? \&$fullname : undef; };
	if ( $opts{method} ) {
		$opts{next} ||= eval { $package->can( $opts{subname} ) };
	}
	if ( $opts{fallback} and not $opts{next} ) {
		$opts{next} = ref( $opts{fallback} ) ? $opts{fallback} : sub {};
	}
	if ( not $opts{next} ) {
		require Error::TypeTiny;
		return Error::TypeTiny::croak( "Function '$function' not found to wrap!" );
	}

	require Type::Params::Signature;
	my $sig = 'Type::Params::Signature'->new_from_v2api( \%opts );
	# Delay compilation
	my $compiled;
	my $coderef = sub {
		$compiled ||= $sig->coderef->compile;

		no strict 'refs';
		no warnings 'redefine';
		*$fullname = set_subname( SIGNATURE_SUBNAME_PREFIX . $fullname . SIGNATURE_SUBNAME_SUFFIX, $compiled );

		goto( $compiled );
	};

	our ( %PRE_INSTALL, %POST_INSTALL );
	if ( my $cb = $PRE_INSTALL{$package} ) {
		Types::Standard::assert_ArrayRef( $cb );
		$_->( $sig ) for @$cb;
	}

	no strict 'refs';
	no warnings 'redefine';
	*$fullname = set_subname( SIGNATURE_SUBNAME_PREFIX . $fullname . SIGNATURE_SUBNAME_SUFFIX, $coderef );

	if ( my $cb = $POST_INSTALL{$package} ) {
		Types::Standard::assert_ArrayRef( $cb );
		$_->( $sig ) for @$cb;
	}

	return $sig;
}

sub signature_for_func {
	if ( not @_ % 2 ) {
		require Error::TypeTiny;
		Error::TypeTiny::croak( "Expected odd-sized list of arguments; did you forget the function name?" );
	}
	my ( $function, %opts ) = @_;
	my $N = !!$opts{named};
	@_ = ( $function, method => 0, allow_dash => $N, list_to_named => $N, %opts );
	goto \&signature_for;
}

sub signature_for_method {
	if ( not @_ % 2 ) {
		require Error::TypeTiny;
		Error::TypeTiny::croak( "Expected odd-sized list of arguments; did you forget the function name?" );
	}
	my ( $function, %opts ) = @_;
	my $N = !!$opts{named};
	@_ = ( $function, method => 1, allow_dash => $N, list_to_named => $N, %opts );
	goto \&signature_for;
}

sub compile {
	my @args = @_;
	@_ = ( positional => \@args );
	goto \&signature;
}

sub compile_named {
	my @args = @_;
	@_ = ( bless => 0, named => \@args );
	goto \&signature;
}

sub compile_named_oo {
	my @args = @_;
	@_ = ( bless => 1, named => \@args );
	goto \&signature;
}

# Would be faster to inline this into validate and validate_named, but
# that would complicate them. :/
sub _mk_key {
	local $_;
	join ':', map {
		Types::Standard::is_HashRef( $_ ) ? do {
			my %h = %$_;
			sprintf( '{%s}', _mk_key( map { ; $_ => $h{$_} } sort keys %h ) );
		} :
		Types::TypeTiny::is_TypeTiny( $_ ) ? sprintf( 'TYPE=%s', $_->{uniq} ) :
		Types::Standard::is_Ref( $_ )      ? sprintf( 'REF=%s', refaddr( $_ ) ) :
		Types::Standard::is_Undef( $_ )    ? sprintf( 'UNDEF' ) :
		B::perlstring( $_ )
	} @_;
} #/ sub _mk_key

{
	my %compiled;
	sub validate {
		my $arg = shift;
		my $sub = (
			$compiled{ _mk_key( @_ ) } ||= signature(
				caller_level => 1,
				%{ ref( $_[0] ) eq 'HASH' ? shift( @_ ) : +{} },
				positional => [ @_ ],
			)
		);
		@_ = @$arg;
		goto $sub;
	} #/ sub validate
}

{
	my %compiled;
	sub validate_named {
		my $arg = shift;
		my $sub = (
			$compiled{ _mk_key( @_ ) } ||= signature(
				caller_level => 1,
				bless => 0,
				%{ ref( $_[0] ) eq 'HASH' ? shift( @_ ) : +{} },
				named => [ @_ ],
			)
		);
		@_ = @$arg;
		goto $sub;
	} #/ sub validate_named
}

sub multisig {
	my %options = ( ref( $_[0] ) eq "HASH" ) ? %{ +shift } : ();
	signature(
		%options,
		multi => \@_,
	);
} #/ sub multisig

sub wrap_methods {
	my $opts = ref( $_[0] ) eq 'HASH' ? shift : {};
	$opts->{caller} ||= caller;
	$opts->{skip_invocant} = 1;
	$opts->{use_can}       = 1;
	unshift @_, $opts;
	goto \&_wrap_subs;
}

sub wrap_subs {
	my $opts = ref( $_[0] ) eq 'HASH' ? shift : {};
	$opts->{caller} ||= caller;
	$opts->{skip_invocant} = 0;
	$opts->{use_can}       = 0;
	unshift @_, $opts;
	goto \&_wrap_subs;
}

sub _wrap_subs {
	my $opts = shift;
	while ( @_ ) {
		my ( $name, $proto ) = splice @_, 0, 2;
		my $fullname = ( $name =~ /::/ ) ? $name : sprintf( '%s::%s', $opts->{caller}, $name );
		my $orig = do {
			no strict 'refs';
			exists &$fullname     ? \&$fullname
				: $opts->{use_can} ? ( $opts->{caller}->can( $name ) || sub { } )
				: sub { }
		};
		my $new;
		if ( ref $proto eq 'CODE' ) {
			$new = $opts->{skip_invocant}
				? sub {
					my $s = shift;
					@_ = ( $s, &$proto );
					goto $orig;
				}
				: sub {
					@_ = &$proto;
					goto $orig;
				};
		}
		else {
			$new = compile(
				{
					'package'   => $opts->{caller},
					'subname'   => $name,
					'next'      => $orig,
					'head'      => $opts->{skip_invocant} ? 1 : 0,
				},
				@$proto,
			);
		}
		no strict 'refs';
		no warnings 'redefine';
		*$fullname = set_subname( $fullname, $new );
	} #/ while ( @_ )
	1;
} #/ sub _wrap_subs

1;

__END__