File Coverage

blib/lib/Data/Validate/Domain.pm

Criterion	Covered	Total	%
statement	63	64	98.4
branch	44	46	95.6
condition	8	12	66.6
subroutine	10	10	100.0
pod	4	4	100.0
total	129	136	94.8

package Data::Validate::Domain;

use strict;
use warnings;

our $VERSION = '0.13';

use Net::Domain::TLD qw(tld_exists);

use Exporter qw( import );

## no critic (Modules::ProhibitAutomaticExportation)
our @EXPORT = qw(
    is_domain
    is_hostname
    is_domain_label
);

sub new {
    my $class = shift;

    return bless {@_}, ref($class) || $class;
}

# -------------------------------------------------------------------------------

sub is_domain {
    my ( $value, $opt ) = _maybe_oo(@_);

    my ( $hostname, $bits ) = _domain_labels( $value, $opt );

    return unless $bits;

    my $tld = $bits->[-1];

    # domain_allow_single_label set to true disables this check
    unless ( $opt->{domain_allow_single_label} ) {

        # All domains have more then 1 label (neely.cx good, com not good)
        return if @{$bits} < 2;
    }

    return $hostname if $opt->{domain_disable_tld_validation};

    # If the option to enable domain_private_tld is enabled
    # and a private domain is specified, then we return if that matches
    if ( exists $opt->{domain_private_tld}
        && ref( $opt->{domain_private_tld} ) ) {
        my $lc_tld = lc($tld);
        if ( ref( $opt->{domain_private_tld} ) eq 'HASH' ) {
            if ( exists $opt->{domain_private_tld}->{$lc_tld} ) {
                return $hostname;
            }
        }
        else {
            if ( $tld =~ $opt->{domain_private_tld} ) {
                return $hostname;
            }
        }
    }

    # Verify domain has a valid TLD
    return unless tld_exists($tld);

    return $hostname;
}

# -------------------------------------------------------------------------------

sub is_hostname {
    my ( $value, $opt ) = _maybe_oo(@_);

    my ($hostname) = _domain_labels( $value, $opt );

    # We do not verify TLD for hostnames, as hostname.subhost is a valid hostname

    return $hostname;
}

sub _domain_labels {
    my ( $value, $opt ) = @_;

    return unless defined($value);

    my $length = length($value);
    return if $length < 0 || $length > 255;

    my $trailing_dot = $value =~ s/\.\z// ? q{.} : q{};

    my @bits;
    foreach my $label ( split /\./, $value, -1 ) {
        my $bit = is_domain_label( $label, $opt );
        return unless defined $bit;
        push( @bits, $bit );
    }

    return unless @bits;

    return ( join( '.', @bits ) . $trailing_dot, \@bits );
}

sub is_domain_label {
    my ( $value, $opt ) = _maybe_oo(@_);

    return unless defined($value);

    # Fix Bug: 41033
    return if ( $value =~ /\n/ );

    # bail if we are dealing with more then just a hostname
    return if ( $value =~ /\./ );
    my $length = length($value);
    my $hostname;
    if ( $length == 1 ) {
        if ( $opt->{domain_allow_underscore} ) {
            ($hostname) = $value =~ /^([0-9A-Za-z\_])$/;
        }
        else {
            ($hostname) = $value =~ /^([0-9A-Za-z])$/;
        }
    }
    elsif ( $length > 1 && $length <= 63 ) {
        if ( $opt->{domain_allow_underscore} ) {
            ($hostname)
                = $value =~ /^([0-9A-Za-z\_][0-9A-Za-z\-\_]*[0-9A-Za-z])$/;
        }
        else {
            ($hostname)
                = $value =~ /^([0-9A-Za-z][0-9A-Za-z\-]*[0-9A-Za-z])$/;
        }
    }
    else {
        return;
    }
    return $hostname;
}

sub _maybe_oo {
    if ( ref $_[0] ) {
        return @_[ 1, 0 ];
    }
    else {
        return ( $_[0], ( defined $_[1] ? $_[1] : {} ) );
    }
}

1;

# ABSTRACT: Domain and host name validation

__END__