File Coverage

blib/lib/Types/Common/Numeric.pm

Criterion	Covered	Total	%
statement	21	21	100.0
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	29	29	100.0

package Types::Common::Numeric;

use 5.008001;
use strict;
use warnings;

BEGIN {
	$Types::Common::Numeric::AUTHORITY = 'cpan:TOBYINK';
	$Types::Common::Numeric::VERSION   = '2.002001';
}

$Types::Common::Numeric::VERSION =~ tr/_//d;

use Type::Library -base, -declare => qw(
	PositiveNum PositiveOrZeroNum
	PositiveInt PositiveOrZeroInt
	NegativeNum NegativeOrZeroNum
	NegativeInt NegativeOrZeroInt
	SingleDigit
	NumRange IntRange
);

use Type::Tiny ();
use Types::Standard qw( Num Int Bool );

sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }

my $meta = __PACKAGE__->meta;

$meta->add_type(
	name       => 'PositiveNum',
	parent     => Num,
	constraint => sub { $_ > 0 },
	inlined    => sub { undef, qq($_ > 0) },
	message    => sub { "Must be a positive number" },
);

$meta->add_type(
	name       => 'PositiveOrZeroNum',
	parent     => Num,
	constraint => sub { $_ >= 0 },
	inlined    => sub { undef, qq($_ >= 0) },
	message    => sub { "Must be a number greater than or equal to zero" },
	type_default => sub { return 0; },
);

my ( $pos_int, $posz_int );
if ( Type::Tiny::_USE_XS ) {
	$pos_int = Type::Tiny::XS::get_coderef_for( 'PositiveInt' )
		if Type::Tiny::XS->VERSION >= 0.013;    # fixed bug with "00"
	$posz_int = Type::Tiny::XS::get_coderef_for( 'PositiveOrZeroInt' );
}

$meta->add_type(
	name       => 'PositiveInt',
	parent     => Int,
	constraint => sub { $_ > 0 },
	inlined    => sub {
		if ( $pos_int ) {
			my $xsub = Type::Tiny::XS::get_subname_for( $_[0]->name );
			return "$xsub($_[1])" if $xsub && !$Type::Tiny::AvoidCallbacks;
		}
		undef, qq($_ > 0);
	},
	message => sub { "Must be a positive integer" },
	$pos_int ? ( compiled_type_constraint => $pos_int ) : (),
);

$meta->add_type(
	name       => 'PositiveOrZeroInt',
	parent     => Int,
	constraint => sub { $_ >= 0 },
	inlined    => sub {
		if ( $posz_int ) {
			my $xsub = Type::Tiny::XS::get_subname_for( $_[0]->name );
			return "$xsub($_[1])" if $xsub && !$Type::Tiny::AvoidCallbacks;
		}
		undef, qq($_ >= 0);
	},
	message => sub { "Must be an integer greater than or equal to zero" },
	$posz_int ? ( compiled_type_constraint => $posz_int ) : (),
	type_default => sub { return 0; },
);

$meta->add_type(
	name       => 'NegativeNum',
	parent     => Num,
	constraint => sub { $_ < 0 },
	inlined    => sub { undef, qq($_ < 0) },
	message    => sub { "Must be a negative number" },
);

$meta->add_type(
	name       => 'NegativeOrZeroNum',
	parent     => Num,
	constraint => sub { $_ <= 0 },
	inlined    => sub { undef, qq($_ <= 0) },
	message    => sub { "Must be a number less than or equal to zero" },
	type_default => sub { return 0; },
);

$meta->add_type(
	name       => 'NegativeInt',
	parent     => Int,
	constraint => sub { $_ < 0 },
	inlined    => sub { undef, qq($_ < 0) },
	message    => sub { "Must be a negative integer" },
);

$meta->add_type(
	name       => 'NegativeOrZeroInt',
	parent     => Int,
	constraint => sub { $_ <= 0 },
	inlined    => sub { undef, qq($_ <= 0) },
	message    => sub { "Must be an integer less than or equal to zero" },
	type_default => sub { return 0; },
);

$meta->add_type(
	name       => 'SingleDigit',
	parent     => Int,
	constraint => sub { $_ >= -9 and $_ <= 9 },
	inlined    => sub { undef, qq($_ >= -9), qq($_ <= 9) },
	message    => sub { "Must be a single digit" },
	type_default => sub { return 0; },
);

for my $base ( qw/Num Int/ ) {
	$meta->add_type(
		name                 => "${base}Range",
		parent               => Types::Standard->get_type( $base ),
		constraint_generator => sub {
			return $meta->get_type( "${base}Range" ) unless @_;

			my $base_obj = Types::Standard->get_type( $base );

			my ( $min, $max, $min_excl, $max_excl ) = @_;
			!defined( $min )
				or $base_obj->check( $min )
				or _croak(
				"${base}Range min must be a %s; got %s", lc( $base ),
				$min
				);
			!defined( $max )
				or $base_obj->check( $max )
				or _croak(
				"${base}Range max must be a %s; got %s", lc( $base ),
				$max
				);
			!defined( $min_excl )
				or Bool->check( $min_excl )
				or _croak( "${base}Range minexcl must be a boolean; got $min_excl" );
			!defined( $max_excl )
				or Bool->check( $max_excl )
				or _croak( "${base}Range maxexcl must be a boolean; got $max_excl" );

			# this is complicated so defer to the inline generator
			eval sprintf(
				'sub { %s }',
				join ' and ',
				grep defined,
				$meta->get_type( "${base}Range" )->inline_generator->( @_ )->( undef, '$_[0]' ),
			);
		},
		inline_generator => sub {
			my ( $min, $max, $min_excl, $max_excl ) = @_;

			my $gt = $min_excl ? '>' : '>=';
			my $lt = $max_excl ? '<' : '<=';

			return sub {
				my $v    = $_[1];
				my @code = ( undef );    # parent constraint
				push @code, "$v $gt $min";
				push @code, "$v $lt $max" if defined $max;
				return @code;
			};
		},
		deep_explanation => sub {
			my ( $type, $value, $varname ) = @_;
			my ( $min, $max, $min_excl, $max_excl ) = @{ $type->parameters || [] };
			my @whines;
			if ( defined $max ) {
				push @whines, sprintf(
					'"%s" expects %s to be %s %d and %s %d',
					$type,
					$varname,
					$min_excl ? 'greater than' : 'at least',
					$min,
					$max_excl ? 'less than' : 'at most',
					$max,
				);
			} #/ if ( defined $max )
			else {
				push @whines, sprintf(
					'"%s" expects %s to be %s %d',
					$type,
					$varname,
					$min_excl ? 'greater than' : 'at least',
					$min,
				);
			}
			push @whines, sprintf(
				"%s is %s",
				$varname,
				$value,
			);
			return \@whines;
		},
	);
} #/ for my $base ( qw/Num Int/)

__PACKAGE__->meta->make_immutable;

1;

__END__