File Coverage

blib/lib/Data/Validate/DNS/NAPTR/Regexp.pm

Criterion	Covered	Total	%
statement	98	99	98.9
branch	41	42	97.6
condition	6	7	85.7
subroutine	10	10	100.0
pod	4	4	100.0
total	159	162	98.1

package Data::Validate::DNS::NAPTR::Regexp;

our $VERSION = '0.007';

use 5.008000;

use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT_OK = qw(is_naptr_regexp naptr_regexp_error);

our @EXPORT = @EXPORT_OK;

my $last_error;

sub new {
	my ($class) = @_;

	return bless {}, $class;
}

sub _set_error {
	my ($where, $error) = @_;

	if ($where) {
		$where->{error} = $error;
	} else {
		$last_error = $error;
	}
}

sub error {
	my ($self) = @_;

	if ($self) {
		return $self->{error};
	} else {
		return $last_error;
	}
}

sub naptr_regexp_error {
	goto &error;
}

sub is_naptr_regexp {
	my ($self, $string) = @_;

	# Called as a function?
	if (defined $self && !ref $self) {
		$string = $self;

		$self = undef;

		$last_error = undef;
	} else {
		$self->{error} = undef;
	}

	if (!defined $string) {
		return 1;
	}

	if ($string =~ /\n/) {
		_set_error($self, "Contains new-lines");

		return 0;
	}

	# Convert from master-file format
	$string = _cstring_from_text($self, $string);

	if (!defined $string) {
		return 0;
	}

	# Empty string okay
	if (length $string == 0) {
		return 2;
	}

	if ($string =~ /\0/) {
		_set_error($self, "Contains null bytes");

		return 0;
	}

	$string =~ s/^(.)//;

	my $delim = $1;

	if ($delim =~ /^[0-9\\i\0]$/) {
		_set_error($self, "Delimiter ($delim) cannot be a flag, digit or null");

		return 0;
	}

	$delim = qr/\Q$delim\E/;

	# Convert double-backslashes to \0 for easy parsing.
	$string =~ s/\\\\/\0/g;

	# Now anything preceeded by a '\' is an escape sequence and can be
	# ignored.

	unless ($string =~ /^
		(.*) (?
		(.*) (?
		(.*)$/x
	) {
		_set_error($self, "Bad syntax, missing replace/end delimiter");

		return 0;
	}

	my ($find, $replace, $flags) = ($1, $2, ($3 || ''));

	# Extra delimiters? Broken
	for my $f ($find, $replace, $flags) {
		if ($f =~ /(?
			_set_error($self, "Extra delimiters");

			return 0;
		}
	}

	# Count backrefs in replace and make sure it matches up.
	my %brefs = map { $_ => 1 } $replace=~ /\\([0-9])/g;

	# And so ends our fun with escapes. Convert those nulls back to double
	# backslashes
	$_ =~ s/\0/\\\\/g for ($find, $replace, $flags);

	# Validate flags
	for my $f (split //, $flags) {
		if ($f eq 'i') {
			# Ok!
		} else {
			_set_error($self, "Bad flag: $f");

			return 0;
		}
	}

	if ($brefs{0}) {
		_set_error($self, "Bad backref '0'");

		return 0;
	}

	# Validate capture count
	my $nsubs = _count_nsubs($find);

	my ($highest) = sort {$a <=> $b} keys %brefs;
	$highest ||= 0;

	if ($nsubs < $highest) {
		_set_error($self, "More backrefs in replacement than captures in match");

		return 0;
	}

	return 3;
}

# Convert master-file character string to data
sub _cstring_from_text {
	my ($self, $string) = @_;

	my $ret;

	# look for escape sequences, one at a time.
	# $1 is data before escape, $2 is \ if found, $3 is what's escaped
	while ($string =~ /\G(.*?)(\\(\d{1,3}|.)?)?/g) {
		my $before = $1;

		# Unescaped double quote?
		if ($before =~ /"/) {
			_set_error($self, 'Unescaped double quote');

			return;
		}

		$ret .= $before;

		# Got an escape
		if ($2) {
			my $seq = $3;

			if (!defined $seq) {
				_set_error($self, 'Trailing backslash');

				return;
			}

			# Some byte? Take it
			if ($seq !~ /\d/) {
				$ret .= $seq;
			} elsif ($seq !~ /\d\d\d/) {
				_set_error($self, "Bad escape sequence '\\$seq'");

				return;
			} elsif ($seq > 255) {
				_set_error($self, "Escape sequence out of range '\\$seq'");

				return;
			} else {
				# Good, take it
				$ret .= chr($seq);
			}
		}
	}

	if (length $ret > 255) {
		_set_error($self, "Must be less than 256 bytes");

		return;
	}

	return $ret;
}

# Count the number of captures in the RE
sub _count_nsubs {
	my ($regex) = @_;

	# Assume any ( not preceded by a \ is a capture start
	my @captures = $regex =~ /(?

	return 0+@captures;
}

1;
__END__