File Coverage

blib/lib/MooX/Value/ValidationUtils.pm

Criterion	Covered	Total	%
statement	43	43	100.0
branch	28	28	100.0
condition	15	15	100.0
subroutine	10	10	100.0
pod	8	8	100.0
total	104	104	100.0

package MooX::Value::ValidationUtils;

use warnings;
use strict;

our $VERSION = '0.04';

# RFC 1123 and 2181
sub why_invalid_domain_name
{
    my ($poss_domain) = @_;

    return ( 'No domain supplied', '', undef ) unless defined $poss_domain;
    return ( 'Domain must be between 1 and 255 octets in length.', '', undef )
        if !length $poss_domain or length $poss_domain > 255;
    my @labels = split( /\./, $poss_domain );
    return ( __PACKAGE__ . ': At least one label is required', '', undef ) unless @labels;

    # Final label can be empty
    my $last = length $labels[0] ? $#labels : $#labels-1;
    foreach my $label ( @labels[0 .. $last] )
    {
        my ($why, $long, $data) = why_invalid_domain_label( $label );
        return ($why, $long, $label) if defined $why;
    }
    return;
}

sub is_valid_domain_name
{
    my ($poss_domain) = @_;
    my ($why) = why_invalid_domain_name( $poss_domain );
    return !defined $why;
}

# RFC 1123 and 2181
sub why_invalid_domain_label
{
    my ($poss_label) = @_;
    return ( 'No domain label supplied', '', undef ) unless defined $poss_label;
    return ( 'Label is not in the length range 1 to 63', '', undef )
        if !length $poss_label or length $poss_label > 63;
    return ( 'Label is not the correct form.', '', undef )
        unless $poss_label =~ m{\A[a-zA-Z0-9]        # No hyphens at front
                                  (?:[-a-zA-Z0-9]*   # hyphens allowed in the middle
                                     [a-zA-Z0-9])?   # No hyphens at the end
                             \z}x;
    return;
}

sub is_valid_domain_label
{
    my ($poss_label) = @_;
    my ($why) = why_invalid_domain_label( $poss_label );
    return !defined $why;
}


# RFC 5322
sub why_invalid_email_local_part
{
    my ($poss_part) = @_;
    return ( 'No email local part supplied', '', undef ) unless defined $poss_part;
    return ( 'Local part is not in the length range 1 to 64', '', undef )
        if !length $poss_part or length $poss_part > 64;
    return ( 'Local part is not correct form.', '', undef )
        unless $poss_part =~ m/\A"(?:\\.|[!#-[\]-~])+"\z/   # quoted string (all 7-bit ASCII except \ and " unless quoted)
            || $poss_part =~ m{\A[a-zA-Z0-9!#\$\%&'*+\-/=?^_`{|}~]+       # any 'atext' characters
                                 (?:\.                                    # separated by dots
                                      [a-zA-Z0-9!#\$\%&'*+\-/=?^_`{|}~]+  # any 'atext' characters
                                 )*
                               \z}x;
    return;
}

sub is_valid_email_local_part
{
    my ($poss_part) = @_;
    my ($why) = why_invalid_email_local_part( $poss_part );
    return !defined $why;
}



# RFC 5322
sub why_invalid_common_email_local_part
{
    my ($poss_part) = @_;
    return ( 'No email local part supplied', '', undef ) unless defined $poss_part;
    return ( 'Local part is not in the length range 1 to 64', '', undef )
        if !length $poss_part or length $poss_part > 64;
    return ( 'Local part is not correct form.', '', undef )
        unless $poss_part =~ m{\A[a-zA-Z0-9!#\$\%&'*+\-/=?^_`{|}~]+       # any 'atext' characters
                                 (?:\.                                    # separated by dots
                                      [a-zA-Z0-9!#\$\%&'*+\-/=?^_`{|}~]+  # any 'atext' characters
                                 )*
                               \z}x;
    return;
}

sub is_valid_common_email_local_part
{
    my ($poss_part) = @_;
    my ($why) = why_invalid_common_email_local_part( $poss_part );
    return !defined $why;
}

1;
__END__