File Coverage

blib/lib/Net/DNS/Multicast.pm

Criterion	Covered	Total	%
statement	49	49	100.0
branch	8	8	100.0
condition	2	2	100.0
subroutine	9	9	100.0
pod	3	5	100.0
total	71	73	100.0

package Net::DNS::Multicast;

use strict;
use warnings;

our $VERSION;
$VERSION = '0.04';

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


## Insert methods into (otherwise empty) Net::DNS::Resolver package

my $defaults = Net::DNS::Resolver->_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 Net::DNS::Resolver::Base::send( $self, $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 Net::DNS::Resolver::Base::bgsend( $self, $packet );
}

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


## Add access methods for M-DNS flags

sub Net::DNS::Question::unicast_response {
	my ( $self, $value ) = @_;				# uncoverable pod
	$self->{qclass} |= 0x8000 if $value;			# set only
	return $self->{qclass} >> 15;				# always defined
}

sub Net::DNS::RR::cache_flush {
	my ( $self, $value ) = @_;				# uncoverable pod
	my $class = $self->{class} || 1;			# IN implicit
	$self->{class} = $class |= 0x8000 if $value;		# set only
	return $class >> 15;
}


1;
__END__