File Coverage

blib/lib/Value/Object/ValidationUtils.pm

Criterion	Covered	Total	%
statement	69	69	100.0
branch	54	60	90.0
condition	30	45	66.6
subroutine	13	13	100.0
pod	10	10	100.0
total	176	197	89.3

package Value::Object::ValidationUtils;

use warnings;
use strict;

our $VERSION = '0.13';

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

sub why_invalid_iso_8601_date
{
    my ($value) = @_;
    return ( 'date is undefined', '', undef ) unless defined $value;
    return ( 'date is empty', '', undef ) unless length $value;
    return ( 'date format is incorrect', '', undef )
        unless $value =~ /\A([0-9]{4})-([0-9]{2})-([0-9]{2})\z/;
    my ($year, $month, $day) = ($1, $2, $3);
    return ( 'value month is out of range', '', $month )
        unless 1 <= $month && $month <= 12;
    return ( 'value day is out of range', '', $day )
        unless 1 <= $day && $day <= 31;
    return ( 'value day is out of range for month', '', $day )
        if $day == 31 && grep { $month == $_ } (2, 4, 6, 9, 11);
    return ( 'value day is out of range for February', '', $day )
        if $day == 30 || ($day == 29 && !_is_leap_year( $year ));
    return;
}

sub _is_leap_year
{
    my ($year) = @_;
    return ($year % 4 == 0 && ($year % 100 != 0 || $year % 400 == 0));
}

sub why_invalid_iso_8601_time
{
    my ($value) = @_;
    return ( 'time is undefined', '', undef ) unless defined $value;
    return ( 'time is empty', '', undef ) unless length $value;
    return ( 'time format is incorrect', '', undef )
        unless $value =~ /\A([0-9]{2}):([0-9]{2})(?::([0-9]{2}(?:\.[0-9]+)?))(Z|[-+][0-9]{2}:[0-9]{2})\z/;
    my ($hour, $minute, $second, $tzi) = ($1, $2, $3, $4);
    return ( 'value hour is out of range', '', $hour )
        unless $hour <= 23 || ($hour == 24 && $minute == 0);
    return ( 'value minute is out of range', '', $minute )
        unless $minute <= 59;
    return ( 'value second is out of range', '', $second )
        unless $second <= 60;  # Account for leap seconds
    return if $tzi eq 'Z';
    my ($tzh, $tzm) = $tzi =~ /(\d+):(\d+)/;
    return ( 'value timezone hour offset is out of range', '', $tzh )
        unless $tzh <= 23 || ($tzh == 24 && $tzm == 0);
    return ( 'value timezone minute offset is out of range', '', $tzm )
        unless $tzm <= 59;
    return;
}

1;
__END__