File Coverage

blib/lib/Net/DNS/Multicast.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	4	4	100.0
condition			n/a
subroutine	9	9	100.0
pod	3	5	100.0
total	66	68	100.0

package Net::DNS::Multicast;

use strict;
use warnings;

our $VERSION;
$VERSION = '0.02_01';

use Net::DNS qw(:DEFAULT);
use base     qw(Exporter Net::DNS);

our @EXPORT = @Net::DNS::EXPORT;

=head1 NAME

Net::DNS::Multicast - Multicast extension to Net::DNS

=head1 SYNOPSIS

    use Net::DNS::Multicast;
    my $resolver = Net::DNS::Resolver->new();
    my $response = $resolver( 'host.local.', 'AAAA' );

=head1 DESCRIPTION

Net::DNS::Multicast is installed as an extension to an existing Net::DNS
installation providing packages to support simple IP multicast queries
as described in RFC6762(5.1).

The multicast feature is made available by replacing Net::DNS by
Net::DNS::Multicast in the use declaration.

The use of IP Multicast is confined to the link-local domains listed in
RFC6762. Queries for other names in the global DNS are directed to the
configured nameservers.

=cut

{

	package Net::DNS::Resolver;	## Add methods to (otherwise empty) package

	my $defaults = __PACKAGE__->_defaults;
	$defaults->{multicast_group} = [qw(FF02::FB 224.0.0.251)];
	$defaults->{multicast_port}  = 5353;

	my $NAME_REGEX = q/\.(local|254\.169\.in-addr\.arpa|[89AB]\.E\.F\.ip6\.arpa)$/;

	sub Net::DNS::Resolver::send {
		my ( $self, @argument ) = @_;
		my $packet = $self->_make_query_packet(@argument);
		my ($q) = $packet->question;

		if ( $q->qname =~ /$NAME_REGEX/oi ) {
			local $packet->{status} = 0;
			local @{$self}{qw(nameservers nameserver4 nameserver6 port retrans)};
			$self->_reset_errorstring;
			$self->nameservers( @{$self->{multicast_group}} );
			$self->port( $self->{multicast_port} );
			$self->retrans(3);
			return $self->_send_udp( $packet, $packet->data );
		}

		return $self->SUPER::send($packet);
	}

	sub Net::DNS::Resolver::bgsend {
		my ( $self, @argument ) = @_;
		my $packet = $self->_make_query_packet(@argument);
		my ($q) = $packet->question;

		if ( $q->qname =~ /$NAME_REGEX/oi ) {
			local $packet->{status} = 0;
			local @{$self}{qw(nameservers nameserver4 nameserver6 port)};
			$self->_reset_errorstring;
			$self->nameservers( @{$self->{multicast_group}} );
			$self->port( $self->{multicast_port} );
			return $self->_bgsend_udp( $packet, $packet->data );
		}

		return $self->SUPER::bgsend($packet);
	}

	sub Net::DNS::Resolver::string {
		my $self = shift;
		return join( '', $self->SUPER::string, <
;; multicast_group	@{$self->{multicast_group}}
;; multicast_ port	$self->{multicast_port}
END
	}


	package Net::DNS::Question;

	sub unicast_response {
		my ( $self, @value ) = @_;			# uncoverable pod
		for (@value) { $self->{qclass} |= ( $_ << 15 ) }
		return $self->{qclass} >> 15;
	}


	package Net::DNS::RR;

	sub cache_flush {
		my ( $self, @value ) = @_;			# uncoverable pod
		for (@value) { $self->{class} |= ( $_ << 15 ) }
		return $self->{class} >> 15;
	}

}

1;
__END__