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


line stmt bran cond sub pod time code
1             package Net::DNS::Multicast;
2              
3 3     3   134249 use strict;
  3         23  
  3         87  
4 3     3   16 use warnings;
  3         5  
  3         170  
5              
6             our $VERSION;
7             $VERSION = '0.04';
8              
9 3     3   1482 use Net::DNS qw(:DEFAULT);
  3         287515  
  3         1257  
10 3     3   53 use base qw(Exporter Net::DNS);
  3         19  
  3         2540  
11              
12             our @EXPORT = @Net::DNS::EXPORT;
13              
14             =head1 NAME
15              
16             Net::DNS::Multicast - Multicast extension to Net::DNS
17              
18             =head1 SYNOPSIS
19              
20             use Net::DNS::Multicast;
21             my $resolver = Net::DNS::Resolver->new();
22             my $response = $resolver( 'host.local.', 'AAAA' );
23              
24             =head1 DESCRIPTION
25              
26             Net::DNS::Multicast is installed as an extension to an existing Net::DNS
27             installation providing packages to support simple IP multicast queries
28             as described in RFC6762(5.1).
29              
30             The multicast feature is made available by replacing Net::DNS by
31             Net::DNS::Multicast in the use declaration.
32              
33             The use of IP Multicast is confined to the link-local domains listed in
34             RFC6762. Queries for other names in the global DNS are directed to the
35             configured nameservers.
36              
37             =cut
38              
39              
40             ## Insert methods into (otherwise empty) Net::DNS::Resolver package
41              
42             my $defaults = Net::DNS::Resolver->_defaults;
43             $defaults->{multicast_group} = [qw(FF02::FB 224.0.0.251)];
44             $defaults->{multicast_port} = 5353;
45              
46             my $NAME_REGEX = q/\.(local|254\.169\.in-addr\.arpa|[89AB]\.E\.F\.ip6\.arpa)$/;
47              
48             sub Net::DNS::Resolver::send {
49 2     2 1 1473 my ( $self, @argument ) = @_;
50 2         12 my $packet = $self->_make_query_packet(@argument);
51 2         13784 my ($q) = $packet->question;
52              
53 2 100       29 if ( $q->qname =~ /$NAME_REGEX/oi ) {
54 1         151 local $packet->{status} = 0;
55 1         5 local @{$self}{qw(nameservers nameserver4 nameserver6 port retrans)};
  1         6  
56 1         14 $self->_reset_errorstring;
57 1         10 $self->nameservers( @{$self->{multicast_group}} );
  1         11  
58 1         109 $self->port( $self->{multicast_port} );
59 1         35 $self->retrans(3);
60 1         11 return $self->_send_udp( $packet, $packet->data );
61             }
62              
63 1         42 return Net::DNS::Resolver::Base::send( $self, $packet );
64             }
65              
66             sub Net::DNS::Resolver::bgsend {
67 2     2 1 1634 my ( $self, @argument ) = @_;
68 2         8 my $packet = $self->_make_query_packet(@argument);
69 2         393 my ($q) = $packet->question;
70              
71 2 100       26 if ( $q->qname =~ /$NAME_REGEX/oi ) {
72 1         60 local $packet->{status} = 0;
73 1         3 local @{$self}{qw(nameservers nameserver4 nameserver6 port)};
  1         5  
74 1         4 $self->_reset_errorstring;
75 1         5 $self->nameservers( @{$self->{multicast_group}} );
  1         4  
76 1         87 $self->port( $self->{multicast_port} );
77 1         10 return $self->_bgsend_udp( $packet, $packet->data );
78             }
79              
80 1         22 return Net::DNS::Resolver::Base::bgsend( $self, $packet );
81             }
82              
83             sub Net::DNS::Resolver::string {
84 1     1 1 546 my $self = shift;
85 1         6 return join( '', Net::DNS::Resolver::Base::string($self), <
86 1         72 ;; multicast_group @{$self->{multicast_group}}
87             ;; multicast_ port $self->{multicast_port}
88             END
89             }
90              
91              
92             ## Add access methods for M-DNS flags
93              
94             sub Net::DNS::Question::unicast_response {
95 3     3 0 2611 my ( $self, $value ) = @_; # uncoverable pod
96 3 100       11 $self->{qclass} |= 0x8000 if $value; # set only
97 3         16 return $self->{qclass} >> 15; # always defined
98             }
99              
100             sub Net::DNS::RR::cache_flush {
101 3     3 0 3350 my ( $self, $value ) = @_; # uncoverable pod
102 3   100     17 my $class = $self->{class} || 1; # IN implicit
103 3 100       12 $self->{class} = $class |= 0x8000 if $value; # set only
104 3         13 return $class >> 15;
105             }
106              
107              
108             1;
109             __END__