File Coverage

blib/lib/AnyEvent/mDNS.pm
Criterion Covered Total %
statement 21 57 36.8
branch 0 12 0.0
condition 0 12 0.0
subroutine 7 14 50.0
pod 1 1 100.0
total 29 96 30.2


line stmt bran cond sub pod time code
1             package AnyEvent::mDNS;
2              
3 1     1   22270 use strict;
  1         3  
  1         32  
4 1     1   22 use 5.008_001;
  1         3  
  1         41  
5             our $VERSION = '0.06';
6              
7 1     1   1633 use AnyEvent 4.84;
  1         5917  
  1         30  
8 1     1   1177 use AnyEvent::DNS;
  1         32592  
  1         46  
9 1     1   1086 use AnyEvent::Handle::UDP;
  1         85927  
  1         48  
10 1     1   11 use AnyEvent::Socket ();
  1         2  
  1         16  
11 1     1   5 use Socket;
  1         2  
  1         1250  
12              
13             sub discover($%) { ## no critic
14 0     0 1   my $cb = sub {};
  0     0      
15 0 0         $cb = pop if @_ % 2 == 0;
16              
17 0           my($proto, %args) = @_;
18              
19 0           my $fqdn = "$proto.local";
20 0           my $data = AnyEvent::DNS::dns_pack { rd => 1, qd => [[$fqdn, "ptr"]] };
21              
22 0           my($name, $alias, $udp_proto) = AnyEvent::Socket::getprotobyname('udp');
23 0           socket my($sock), PF_INET, SOCK_DGRAM, $udp_proto;
24 0           AnyEvent::Util::fh_nonblocking $sock, 1;
25             bind $sock, sockaddr_in(0, Socket::inet_aton('0.0.0.0'))
26 0 0 0 0     or ($args{on_error} || sub { die @_ })->($!);
  0            
27              
28 0           my %found;
29 0   0 0     my $callback = $args{on_found} || sub {};
  0            
30              
31 0           my $t; $t = AnyEvent::Handle::UDP->new(
32             fh => $sock,
33             timeout => $args{timeout} || 3,
34             on_timeout => sub {
35 0     0     undef $t;
36 0           $cb->(values %found);
37             },
38             on_recv => sub {
39 0     0     my $buf = shift;
40 0           my $res = AnyEvent::DNS::dns_unpack $buf;
41              
42 0 0         my @rr = grep { lc $_->[0] eq $fqdn && $_->[1] eq 'ptr' } @{ $res->{an} };
  0            
  0            
43 0           my @srv = grep { $_->[1] eq 'srv' } @{$res->{ar}};
  0            
  0            
44              
45 0 0 0       if (@rr == 1 && @srv == 1) {
46 0           my $name = $rr[0]->[4];
47 0           $name =~ s/\.$fqdn$//;
48              
49 0           my $service = {
50             name => $name,
51             host => $srv[0]->[7],
52             port => $srv[0]->[6],
53             proto => $proto,
54             };
55              
56 0   0       $found{$rr[0]->[4]} ||= do {
57 0 0         $callback->($service) if $callback;
58 0           $service;
59             };
60             }
61             },
62 0   0       );
63              
64 0           send $sock, $data, 0, sockaddr_in(5353, Socket::inet_aton('224.0.0.251'));
65 0 0   0     defined wantarray && AnyEvent::Util::guard { undef $t };
  0            
66             }
67              
68             1;
69             __END__