File Coverage

blib/lib/Types/Common/String.pm

Criterion	Covered	Total	%
statement	25	25	100.0
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	34	100.0

package Types::Common::String;

use 5.008001;
use strict;
use warnings;
use utf8;

BEGIN {
	$Types::Common::String::AUTHORITY = 'cpan:TOBYINK';
	$Types::Common::String::VERSION   = '2.010001';
}

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

use Type::Library -base, -declare => qw(
	SimpleStr
	NonEmptySimpleStr
	NumericCode
	LowerCaseSimpleStr
	UpperCaseSimpleStr
	Password
	StrongPassword
	NonEmptyStr
	LowerCaseStr
	UpperCaseStr
	StrLength
	DelimitedStr
);

use Type::Tiny ();
use Types::TypeTiny ();
use Types::Standard qw( Str );

my $meta = __PACKAGE__->meta;

$meta->add_type(
	name       => SimpleStr,
	parent     => Str,
	constraint => sub { length( $_ ) <= 255 and not /\n/ },
	inlined    => sub { undef, qq(length($_) <= 255), qq($_ !~ /\\n/) },
	message    => sub { "Must be a single line of no more than 255 chars" },
	type_default => sub { return ''; },
);

$meta->add_type(
	name       => NonEmptySimpleStr,
	parent     => SimpleStr,
	constraint => sub { length( $_ ) > 0 },
	inlined    => sub { undef, qq(length($_) > 0) },
	message => sub { "Must be a non-empty single line of no more than 255 chars" },
);

$meta->add_type(
	name       => NumericCode,
	parent     => NonEmptySimpleStr,
	constraint => sub { /^[0-9]+$/ },
	inlined    => sub { SimpleStr->inline_check( $_ ), qq($_ =~ m/^[0-9]+\$/) },
	message    => sub {
		'Must be a non-empty single line of no more than 255 chars that consists '
			. 'of numeric characters only';
	},
);

NumericCode->coercion->add_type_coercions(
	NonEmptySimpleStr,
	q[ do { (my $code = $_) =~ s/[[:punct:][:space:]]//g; $code } ],
);

$meta->add_type(
	name       => Password,
	parent     => NonEmptySimpleStr,
	constraint => sub { length( $_ ) > 3 },
	inlined    => sub { SimpleStr->inline_check( $_ ), qq(length($_) > 3) },
	message    => sub { "Must be between 4 and 255 chars" },
);

$meta->add_type(
	name       => StrongPassword,
	parent     => Password,
	constraint => sub { length( $_ ) > 7 and /[^a-zA-Z]/ },
	inlined    => sub {
		SimpleStr()->inline_check( $_ ), qq(length($_) > 7), qq($_ =~ /[^a-zA-Z]/);
	},
	message => sub {
		"Must be between 8 and 255 chars, and contain a non-alpha char";
	},
);

my ( $nestr );
if ( Type::Tiny::_USE_XS ) {
	$nestr = Type::Tiny::XS::get_coderef_for( 'NonEmptyStr' );
}

$meta->add_type(
	name       => NonEmptyStr,
	parent     => Str,
	constraint => sub { length( $_ ) > 0 },
	inlined    => sub {
		if ( $nestr ) {
			my $xsub = Type::Tiny::XS::get_subname_for( $_[0]->name );
			return "$xsub($_[1])" if $xsub && !$Type::Tiny::AvoidCallbacks;
		}
		undef, qq(length($_) > 0);
	},
	message => sub { "Must not be empty" },
	$nestr ? ( compiled_type_constraint => $nestr ) : (),
);

$meta->add_type(
	name       => LowerCaseStr,
	parent     => NonEmptyStr,
	constraint => sub { !/\p{Upper}/ms },
	inlined    => sub { undef, qq($_ !~ /\\p{Upper}/ms) },
	message    => sub { "Must not contain upper case letters" },
);

LowerCaseStr->coercion->add_type_coercions(
	NonEmptyStr, q[ lc($_) ],
);

$meta->add_type(
	name       => UpperCaseStr,
	parent     => NonEmptyStr,
	constraint => sub { !/\p{Lower}/ms },
	inlined    => sub { undef, qq($_ !~ /\\p{Lower}/ms) },
	message    => sub { "Must not contain lower case letters" },
);

UpperCaseStr->coercion->add_type_coercions(
	NonEmptyStr, q[ uc($_) ],
);

$meta->add_type(
	name       => LowerCaseSimpleStr,
	parent     => NonEmptySimpleStr,
	constraint => sub { !/\p{Upper}/ms },
	inlined    => sub { undef, qq($_ !~ /\\p{Upper}/ms) },
	message    => sub { "Must not contain upper case letters" },
);

LowerCaseSimpleStr->coercion->add_type_coercions(
	NonEmptySimpleStr, q[ lc($_) ],
);

$meta->add_type(
	name       => UpperCaseSimpleStr,
	parent     => NonEmptySimpleStr,
	constraint => sub { !/\p{Lower}/ms },
	inlined    => sub { undef, qq($_ !~ /\\p{Lower}/ms) },
	message    => sub { "Must not contain lower case letters" },
);

UpperCaseSimpleStr->coercion->add_type_coercions(
	NonEmptySimpleStr, q[ uc($_) ],
);

$meta->add_type(
	name                 => StrLength,
	parent               => Str,
	constraint_generator => sub {
		return $meta->get_type( 'StrLength' ) unless @_;

		Type::Tiny::check_parameter_count_for_parameterized_type( 'Types::Common::String', "StrLength", \@_, 2 );
		my ( $min, $max ) = @_;
		Types::Standard::is_Int( $_ )
			|| Types::Standard::_croak(
			"Parameters for StrLength[`min, `max] expected to be integers; got $_" )
			for @_;

		if ( defined $max ) {
			return sub { length( $_[0] ) >= $min and length( $_[0] ) <= $max };
		}
		else {
			return sub { length( $_[0] ) >= $min };
		}
	},
	inline_generator => sub {
		my ( $min, $max ) = @_;

		return sub {
			my $v    = $_[1];
			my @code = ( undef );    # parent constraint
			push @code, "length($v) >= $min";
			push @code, "length($v) <= $max" if defined $max;
			return @code;
		};
	},
	deep_explanation => sub {
		my ( $type, $value, $varname ) = @_;
		my ( $min, $max ) = @{ $type->parameters || [] };
		my @whines;
		if ( defined $max ) {
			push @whines, sprintf(
				'"%s" expects length(%s) to be between %d and %d',
				$type,
				$varname,
				$min,
				$max,
			);
		}
		else {
			push @whines, sprintf(
				'"%s" expects length(%s) to be at least %d',
				$type,
				$varname,
				$min,
			);
		}
		push @whines, sprintf(
			"length(%s) is %d",
			$varname,
			length( $value ),
		);
		return \@whines;
	},
);

$meta->add_type(
	name                 => DelimitedStr,
	parent               => Str,
	type_default         => undef,
	constraint_generator => sub {
		return $meta->get_type( 'DelimitedStr' ) unless @_;

		Type::Tiny::check_parameter_count_for_parameterized_type( 'Types::Common::String', "DelimitedStr", \@_, 5 );
		my ( $delimiter, $part_constraint, $min_parts, $max_parts, $ws ) = @_;

		Types::Standard::assert_Str( $delimiter );
		Types::TypeTiny::assert_TypeTiny( $part_constraint )
			if defined $part_constraint;
		$min_parts ||= 0;
		my $q_delimiter = $ws
			? sprintf( '\s*%s\s*', quotemeta( $delimiter ) )
			: quotemeta( $delimiter );

		return sub {
			my @split = $ws
				? split( $q_delimiter, do { ( my $trimmed = $_[0] ) =~ s{\A\s+|\s+\z}{}g; $trimmed } )
				: split( $q_delimiter, $_[0] );
			return if @split < $min_parts;
			return if defined($max_parts) && ( @split > $max_parts );
			!$part_constraint or $part_constraint->all( @split );
		};
	},
	inline_generator => sub {
		my ( $delimiter, $part_constraint, $min_parts, $max_parts, $ws ) = @_;
		$min_parts ||= 0;
		my $q_delimiter = $ws
			? sprintf( '\s*%s\s*', quotemeta( $delimiter ) )
			: quotemeta( $delimiter );

		return sub {
			my $v = $_[1];
			my @cond;
			push @cond, "\@\$split >= $min_parts" if $min_parts > 0;
			push @cond, "\@\$split <= $max_parts" if defined $max_parts;
			push @cond, Types::Standard::ArrayRef->of( $part_constraint )->inline_check( '$split' )
				if $part_constraint && $part_constraint->{uniq} != Types::Standard::Any->{uniq};
			return ( undef ) if ! @cond;
			return (
				undef,
				sprintf(
					'do { my $split = [ split %s, %s ]; %s }',
					B::perlstring( $q_delimiter ),
					$ws ? sprintf( 'do { ( my $trimmed = %s ) =~ s{\A\s+|\s+\z}{}g; $trimmed }', $v ) : $v,
					join( q{ and }, @cond ),
				),
			);
		};
	},
	coercion_generator => sub {
		my ( $parent, $self, $delimiter, $part_constraint, $min_parts, $max_parts ) = @_;
		return unless $delimiter;
		$part_constraint ||= Types::Standard::Str;
		$min_parts       ||= 0;

		require Type::Coercion;
		my $c = 'Type::Coercion'->new( type_constraint => $self );
		$c->add_type_coercions(
			Types::Standard::ArrayRef->of(
				$part_constraint,
				$min_parts,
				defined $max_parts ? $max_parts : (),
			),
			sprintf( 'join( %s, @$_ )', B::perlstring( $delimiter ) ),
		);
		return $c;
	},
);

DelimitedStr->coercion->add_type_coercions(
	Types::Standard::ArrayRef->of( Types::Standard::Str ),
	'join( $", @$_ )',
);

__PACKAGE__->meta->make_immutable;

1;

__END__