File Coverage

blib/lib/Net/DNS/Method/Regexp.pm

Criterion	Covered	Total	%
statement	20	52	38.4
branch	1	30	3.3
condition	1	29	3.4
subroutine	6	8	75.0
pod	0	2	0.0
total	28	121	23.1

package Net::DNS::Method::Regexp;

require 5.005_62;

use Carp;
use strict;
use warnings;
use Net::DNS::Method;
use vars qw($VERSION @ISA $AUTOLOAD);

$VERSION = '2.00';
our $DEBUG = 0;

our @ISA = qw(Net::DNS::Method);

sub new {
    my $type = shift;
    my $class = ref($type) || $type || "Net::DNS::Method::Regexp";

    my $ref = shift;

    croak "Missing initialization parameters\n" unless ref($ref) eq 'HASH';

    return bless { ref => $ref }, $class;
}

sub ANY {
    my $self	= shift;
    my $q	= shift;
    my $ans	= shift;

    warn "inside ANY" if $DEBUG;

    return NS_FAIL unless $self and $q and $ans;

    my $qs = $q->qname . ' ' . $q->qclass . ' ' . $q->qtype;

    for my $re (sort { length $b <=> length $a } keys %{$self->{ref}}) {
	if ($qs =~ /$re/ix)
	{

	    warn "match on $re for question $qs" if $DEBUG;

	    my $s = $self->{ref}->{$re};

				# First, push RRs in the corresponding zones

	    for my $z (qw(answer authority additional question)) {
		next unless exists $s->{$z} and defined $s->{$z};
		croak "$re->$z must be undef or an array reference"
		    unless ref($s->{$z}) eq 'ARRAY';
		for my $rr (@{$s->{$z}}) {
		    $ans->safe_push($z, $rr);
		}
	    }

				# Next, set the answer bits to the requested
				# values

	    $ans->header->ra($s->{ra})
		if exists $s->{ra} and defined $s->{ra};

	    $ans->header->rd($s->{rd})
		if exists $s->{rd} and defined $s->{rd};

	    $ans->header->aa($s->{aa})
		if exists $s->{aa} and defined $s->{aa};

	    $ans->header->tc($s->{tc})
		if exists $s->{tc} and defined $s->{tc};

				# Next, set the answer's result code

	    if (exists $s->{code} and defined $s->{code}) {
		$ans->header->rcode($s->{code});
	    }
	    else {
		$ans->header->rcode('NOERROR');
	    }

				# Finally, return the requested value or our
				# default

	    if (exists $s->{return} and defined $s->{return}) {
		return $s->{return};
	    }
	    else {
		return NS_OK | NS_STOP;
	    }
	}
    }
    return NS_FAIL;
}

sub AUTOLOAD {
    return undef if $AUTOLOAD eq 'Net::DNS::Method::Regexp::DESTROY';

    warn "call to $AUTOLOAD" if $DEBUG;

    goto &ANY;
}

1;
__END__