File Coverage

blib/lib/Net/Server/Proto/UDP.pm
Criterion Covered Total %
statement 50 59 84.7
branch 23 42 54.7
condition 4 12 33.3
subroutine 8 8 100.0
pod 2 6 33.3
total 87 127 68.5


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::Proto::UDP - Net::Server Protocol module
4             #
5             # Copyright (C) 2001-2017
6             #
7             # Paul Seamons
8             #
9             # Modified 2005 by Timothy Watt
10             # Added ability to deal with broadcast packets.
11             #
12             # This package may be distributed under the terms of either the
13             # GNU General Public License
14             # or the
15             # Perl Artistic License
16             #
17             # All rights reserved.
18             #
19             ################################################################
20              
21             package Net::Server::Proto::UDP;
22              
23 2     2   15 use strict;
  2         5  
  2         299  
24 2     2   14 use base qw(Net::Server::Proto::TCP);
  2         4  
  2         2341  
25              
26             my @udp_args = qw(
27             udp_recv_len
28             udp_recv_flags
29             udp_broadcast
30             );
31              
32 15     15 0 164 sub NS_proto { 'UDP' }
33 13 100   13 0 25 sub NS_recv_len { my $sock = shift; ${*$sock}{'NS_recv_len'} = shift if @_; return ${*$sock}{'NS_recv_len'} }
  13         32  
  10         22  
  13         24  
  13         28  
34 13 100   13 0 20 sub NS_recv_flags { my $sock = shift; ${*$sock}{'NS_recv_flags'} = shift if @_; return ${*$sock}{'NS_recv_flags'} }
  13         30  
  10         21  
  13         22  
  13         47  
35 13 100   13 0 23 sub NS_broadcast { my $sock = shift; ${*$sock}{'NS_broadcast'} = shift if @_; return ${*$sock}{'NS_broadcast'} }
  13         32  
  10         30  
  13         23  
  13         39  
36              
37             sub object {
38 10     10 1 27 my ($class, $info, $server) = @_;
39              
40             # we cannot do this at compile time because we have not yet read the configuration then
41             # (this is the height of rudeness changing another's class on their behalf)
42 10 50 33     51 @Net::Server::Proto::TCP::ISA = qw(IO::Socket::INET6) if $Net::Server::Proto::TCP::ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server);
43              
44 10   33     35 my $udp = $server->{'server'}->{'udp_args'} ||= do {
45 10         20 my %temp = map {$_ => undef} @udp_args;
  30         81  
46 10         22 $server->configure({map {$_ => \$temp{$_}} @udp_args});
  30         113  
47 10         40 \%temp;
48             };
49              
50             my $len = defined($info->{'udp_recv_len'}) ? $info->{'udp_recv_len'}
51 10 100       35 : defined($udp->{'udp_recv_len'}) ? $udp->{'udp_recv_len'}
    50          
52             : 4096;
53 10 50       72 $len = ($len =~ /^(\d+)$/) ? $1 : 4096;
54              
55             my $flg = defined($info->{'udp_recv_flags'}) ? $info->{'udp_recv_flags'}
56 10 50       36 : defined($udp->{'udp_recv_flags'}) ? $udp->{'udp_recv_flags'}
    50          
57             : 0;
58 10 50       39 $flg = ($flg =~ /^(\d+)$/) ? $1 : 0;
59              
60 10         55 my @sock = $class->SUPER::new(); # it is possible that multiple connections will be returned if INET6 is in effect
61 10         809 foreach my $sock (@sock) {
62 10         45 $sock->NS_host($info->{'host'});
63 10         36 $sock->NS_port($info->{'port'});
64 10         36 $sock->NS_ipv( $info->{'ipv'} );
65 10         32 $sock->NS_recv_len($len);
66 10         31 $sock->NS_recv_flags($flg);
67 10 50       55 $sock->NS_broadcast(exists($info->{'udp_broadcast'}) ? $info->{'udp_broadcast'} : $udp->{'upd_broadcast'});
68 10 50       42 ${*$sock}{'NS_orig_port'} = $info->{'orig_port'} if defined $info->{'orig_port'};
  0         0  
69             }
70 10 50       49 return wantarray ? @sock : $sock[0];
71             }
72              
73             sub connect {
74 1     1 1 3 my ($sock, $server) = @_;
75 1         3 my $host = $sock->NS_host;
76 1         3 my $port = $sock->NS_port;
77 1         14 my $ipv = $sock->NS_ipv;
78              
79 1 50       20 $sock->SUPER::configure({
    0          
    0          
    50          
    50          
    50          
80             LocalPort => $port,
81             Proto => 'udp',
82             ReuseAddr => 1,
83             Reuse => 1, # may not be needed on UDP
84             (($host ne '*') ? (LocalAddr => $host) : ()), # * is all
85             ($sock->isa("IO::Socket::INET6") ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()),
86             ($sock->NS_broadcast ? (Broadcast => 1) : ()),
87             }) or $server->fatal("Cannot bind to UDP port $port on $host [$!]");
88              
89 1 50 33     233 if ($port eq 0 and $port = $sock->sockport) {
    50 33        
90 0           $server->log(2, " Bound to auto-assigned port $port");
91 0           ${*$sock}{'NS_orig_port'} = $sock->NS_port;
  0            
92 0           $sock->NS_port($port);
93             } elsif ($port =~ /\D/ and $port = $sock->sockport) {
94 0           $server->log(2, " Bound to service port ".$sock->NS_port()."($port)");
95 0           ${*$sock}{'NS_orig_port'} = $sock->NS_port;
  0            
96 0           $sock->NS_port($port);
97             }
98             }
99              
100             1;
101              
102             __END__