File Coverage

blib/lib/Net/Server/Proto/UNIXDGRAM.pm
Criterion Covered Total %
statement 38 42 90.4
branch 12 22 54.5
condition 1 6 16.6
subroutine 8 9 88.8
pod 1 6 16.6
total 60 85 70.5


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::Proto::UNIXDGRAM - Net::Server Protocol module
4             #
5             # Copyright (C) 2001-2022
6             #
7             # Paul Seamons
8             #
9             # This package may be distributed under the terms of either the
10             # GNU General Public License
11             # or the
12             # Perl Artistic License
13             #
14             # All rights reserved.
15             #
16             ################################################################
17              
18             package Net::Server::Proto::UNIXDGRAM;
19              
20 1     1   6 use strict;
  1         1  
  1         29  
21 1     1   4 use base qw(Net::Server::Proto::UNIX);
  1         2  
  1         80  
22 1     1   5 use Socket qw(SOCK_DGRAM);
  1         1  
  1         554  
23              
24             my @udp_args = qw(
25             udp_recv_len
26             udp_recv_flags
27             udp_broadcast
28             ); # we do broadcast just for caching parallelism with UDP.pm
29              
30 5     5 0 11 sub NS_proto { 'UNIXDGRAM' }
31 5 100   5 0 7 sub NS_recv_len { my $sock = shift; ${*$sock}{'NS_recv_len'} = shift if @_; return ${*$sock}{'NS_recv_len'} }
  5         10  
  4         7  
  5         8  
  5         10  
32 5 100   5 0 8 sub NS_recv_flags { my $sock = shift; ${*$sock}{'NS_recv_flags'} = shift if @_; return ${*$sock}{'NS_recv_flags'} }
  5         11  
  4         6  
  5         7  
  5         8  
33 1     1 1 4 sub NS_unix_type { 'SOCK_DGRAM' }
34              
35             sub object {
36 4     4 0 8 my ($class, $info, $server) = @_;
37              
38 4   33     15 my $udp = $server->{'server'}->{'udp_args'} ||= do {
39 4         6 my %temp = map {$_ => undef} @udp_args;
  12         24  
40 4         6 $server->configure({map {$_ => \$temp{$_}} @udp_args});
  12         27  
41 4         13 \%temp;
42             };
43              
44             my $len = defined($info->{'udp_recv_len'}) ? $info->{'udp_recv_len'}
45 4 100       10 : defined($udp->{'udp_recv_len'}) ? $udp->{'udp_recv_len'}
    50          
46             : 4096;
47 4 50       18 $len = ($len =~ /^(\d+)$/) ? $1 : 4096;
48              
49             my $flg = defined($info->{'udp_recv_flags'}) ? $info->{'udp_recv_flags'}
50 4 50       10 : defined($udp->{'udp_recv_flags'}) ? $udp->{'udp_recv_flags'}
    50          
51             : 0;
52 4 50       13 $flg = ($flg =~ /^(\d+)$/) ? $1 : 0;
53              
54 4         17 my $sock = $class->SUPER::new();
55 4 50       256 my $port = $info->{'port'} =~ m{^ ([\w\.\-\*\/]+) $ }x ? $1 : $server->fatal("Insecure filename");
56 4         13 $sock->NS_port($port);
57 4         10 $sock->NS_recv_len($len);
58 4         8 $sock->NS_recv_flags($flg);
59 4         15 return $sock;
60             }
61              
62             sub connect {
63 0     0 0   my ($sock, $server) = @_;
64 0           my $path = $sock->NS_port;
65 0 0 0       $server->fatal("Can't connect to UNIXDGRAM socket at file $path [$!]") if -e $path && ! unlink $path;
66              
67 0 0         $sock->SUPER::configure({
68             Local => $path,
69             Type => SOCK_DGRAM,
70             }) or $server->fatal("Can't connect to UNIXDGRAM socket at file $path [$!]");
71             }
72              
73             1;
74              
75             __END__