File Coverage

blib/lib/Validate/Net.pm

Criterion	Covered	Total	%
statement	62	80	77.5
branch	27	44	61.3
condition	3	8	37.5
subroutine	11	15	73.3
pod	4	10	40.0
total	107	157	68.1

package Validate::Net;

# Validate::Net is designed to allow you to test net related string to
# determine their relative "validity".

# We use Class::Default to allow us to create a "default" validator
# which has a "medium" setting. Settings are discussed later.

use 5.005;
use strict;
use base 'Class::Default';

# Globals
use vars qw{$VERSION $errstr $reason};
BEGIN {
	$VERSION = '0.6';
	$errstr  = '';
	$reason  = ''
}





#####################################################################
# Constructor and Friends

sub new {
	my $class = shift;
	my $depth = shift || 'local';

	# Create the validtor object
	my $self = bless {
		depth => undef,
		}, $class;

	# Set the depth
	$self->depth( $depth ) or return undef;
	$self;
}

sub depth {
	my $self = shift;
	unless ( ref $self ) {
		return $self->andError( "Cannot change the depth of the default object. You should instantiate instead" );
	}

	my $depth = shift;
	return $self->{depth} unless defined $depth;
	unless ( $depth eq 'fast' or $depth eq 'local' or $depth eq 'full' ) {
		return $self->andError( "Invalid depth '$depth'. Valid depths are 'fast', 'local'(default) or 'full'" );
	}
	$self->{depth} = $depth;
	1;
}





#####################################################################
# Testing

# Validate an ip address
sub ip {
	my $self = shift->_self;
	my $ip = shift or return undef;

	# Clear the reason
	$reason = '';

	# First, do a basic character test.
	# Just what we can get away with in a regex.
	unless ( $ip =~ /^[0-9]\d{0,2}(?:\.[0-9]\d{0,2}){3}$/ ) {
		return $self->withReason( 'Does not fit the basic dotted quad format for an ip' );
	}

	# Split into parts in preperation for the remaining tests
	my @quad = split /\./, $ip;

	# Make sure the basic numeric range is ok
	if ( scalar grep { $_ > 255 } @quad ) {
		return $self->withReason( 'The maximum value for an ip element is 255' );
	}

	# End of the fast tests
	return 1 if $self->{depth} eq 'fast';

	### Add tests for options

	1;
}

# Validate a full or partial domain name, or just a host name
sub domain {
	my $self = shift->_self;
	my $domain = lc shift or return undef;

	# Do a quick check for any invalid characters, or basic problems
	if ( $domain =~ /[^a-z0-9\.-]/ ) {
		return $self->withReason( "Domain '$domain' contains invalid characters" );
	}
	if ( $domain =~ /\.\./ ) {
		return $self->withReason( "Domain '$domain' contains consecutive dots" );
	}
	if ( $domain =~ /^\./ ) {
		return $self->withReason( "Domain '$domain' cannot start with a dot" );
	}

	# The use of a trailing dot is allowed, but we remove it for testing purposes.
	$domain =~ s/\.$//;

	# Split into elements
	my @elements = split /\./, $domain;

	# Check each element individually
	foreach my $element ( @elements ) {
		# Segments can be no more than 63 characters
		if ( length $element > 63 ) {
			return $self->withReason( "Domain section '$element' cannot be longer than 63 characters" );
		}

		# Segments are allowed to contain only digits
		next if $element =~ /^\d+$/;

		# Segment must start with a letter
		if ( $element !~ /^[a-z]/ ) {
			return $self->withReason( "Domain section '$element' must start with a letter" );
		}

		# Segment must end with a letter or number
		if ( $element !~ /[a-z0-9]$/ ) {
			return $self->withReason( "Domain section '$element' must end with a letter or number" );
		}

		# Cannot have two consecutive dashes ( RFC doesn't say so that I can find... is this correct? )
		if ( $element =~ /--/ ) {
			return $self->withReason( "Domain sections '$element' cannot have two dashes in a row" );
		}
	}

	return 1 if $self->{depth} eq 'fast';

	### Add tests for options

	1;
}

# Validate a host.
# A host is EITHER an ip address, or a domain
sub host {
	my $self = shift->_self;
	my $host = shift;

	# Test as an ip or a domain
	$host =~ /^\d+\.\d+\.\d+\.\d+$/
		? $self->ip( $host )
		: $self->domain( $host );
}

# Validate a port number
sub port {
	my $self = shift->_self;
	my $port = shift;

	# A port must be all numbers
	if ( $port =~ /[^0-9]/ ) {
		return $self->withReason( 'A port number must be an integer' );
	}

	# A port cannot start with 0
	if ( $port =~ /^0/ ) {
		return $self->withReason( 'A port number cannot start with zero' );
	}

	# A port must be less than or equal to 65535
	if ( $port > 65535 ) {
		return $self->withReason( 'The port number is too high' );
	}

	# Otherwise OK
	1;
}




#####################################################################
# Error and Message Handling

sub andError   { $errstr = $_[1]; undef }
sub withReason { $reason = $_[1]; '' }
sub errstr     { $errstr }
sub reason     { $reason }

1;

__END__