File Coverage

blib/lib/Mail/Milter/Authentication/Net/ServerPatches.pm
Criterion Covered Total %
statement 32 125 25.6
branch 3 54 5.5
condition 3 15 20.0
subroutine 11 15 73.3
pod 3 4 75.0
total 52 213 24.4


line stmt bran cond sub pod time code
1             package Mail::Milter::Authentication::Net::ServerPatches;
2 127     127   2105 use 5.20.0;
  127         573  
3 127     127   795 use strict;
  127         329  
  127         2632  
4 127     127   1520 use warnings;
  127         603  
  127         5756  
5 127     127   939 use Mail::Milter::Authentication::Pragmas;
  127         463  
  127         1504  
6             # ABSTRACT: Patches to Net::Server::PreFork
7             our $VERSION = '3.20230911'; # VERSION
8 127     127   32231 use base 'Net::Server::PreFork';
  127         328  
  127         73246  
9 127     127   3467389 use POSIX qw(EINTR);
  127         774  
  127         755  
10 127     127   78266 use SUPER;
  127         157978  
  127         680  
11 127     127   6213 use Socket qw(AF_INET AF_UNIX SOCK_DGRAM SOCK_STREAM);
  127         552  
  127         216246  
12              
13              
14             sub run_child {
15 23     23 1 143846 my $self = shift;
16              
17 23   33     1679 my $config = $self->{config} || get_config();
18 23 50       2879 return $self->SUPER unless $config->{'patch_net_server'};
19              
20 0         0 my $prop = $self->{'server'};
21              
22             $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = sub {
23 0     0   0 $self->child_finish_hook;
24 0         0 exit;
25 0         0 };
26 0         0 $SIG{'PIPE'} = 'IGNORE';
27 0         0 $SIG{'CHLD'} = 'DEFAULT';
28             $SIG{'HUP'} = sub {
29 0 0   0   0 if (! $prop->{'connected'}) {
30 0         0 $self->child_finish_hook;
31 0         0 exit;
32             }
33 0         0 $prop->{'SigHUPed'} = 1;
34 0         0 };
35              
36             # Open in child at start
37 0 0       0 if ($prop->{'serialize'} eq 'flock') {
38 0 0       0 open $prop->{'lock_fh'}, ">", $prop->{'lock_file'}
39             or $self->fatal("Couldn't open lock file \"$prop->{'lock_file'}\"[$!]");
40             # With flock() serialization, make things HUP safe
41 0         0 pipe($prop->{'SigHUPReadPipe'}, $prop->{'SigHUPWritePipe'});
42 0         0 $prop->{'select'}->add($prop->{'SigHUPReadPipe'});
43 0 0   0   0 $SIG{'HUP'} = sub { $prop->{'SigHUPed'} = 1; syswrite $prop->{'SigHUPWritePipe'}, "1" if !$prop->{SigHUPWriten}++; };
  0         0  
  0         0  
44             }
45              
46 0         0 $self->log(4, "Child Preforked ($$)");
47              
48 0         0 delete @{ $prop }{qw(children tally last_start last_process)};
  0         0  
49              
50 0         0 $self->child_init_hook;
51 0         0 my $write = $prop->{'_WRITE'};
52              
53 0         0 while ($self->accept()) {
54 0         0 $prop->{'connected'} = 1;
55 0         0 print $write "$$ processing\n";
56              
57 0         0 my $ok = eval { $self->run_client_connection; 1 };
  0         0  
  0         0  
58 0 0       0 if (! $ok) {
59 0         0 print $write "$$ exiting\n";
60 0         0 die $@;
61             }
62              
63 0 0       0 last if $self->done;
64              
65 0         0 $prop->{'connected'} = 0;
66 0         0 print $write "$$ waiting\n";
67             }
68              
69 0         0 $self->child_finish_hook;
70              
71 0         0 print $write "$$ exiting\n";
72 0         0 exit;
73             }
74              
75              
76             sub accept { ## no critic
77 103     103 1 18735 my $self = shift;
78              
79 103   33     762 my $config = $self->{config} || get_config();
80 103 50       1333 return $self->SUPER unless $config->{'patch_net_server'};
81              
82 0         0 my $prop = $self->{'server'};
83              
84 0 0       0 if ($prop->{'serialize'} eq 'flock') {
    0          
    0          
85 0         0 while (! flock $prop->{'lock_fh'}, Fcntl::LOCK_EX()) {
86 0 0       0 return undef if $prop->{'SigHUPed'}; ## no critic
87 0 0       0 next if $! == EINTR;
88 0         0 $self->fatal("Couldn't get lock on file \"$prop->{'lock_file'}\" [$!]");
89             }
90 0         0 my $v = $self->super_accept();
91 0         0 flock $prop->{'lock_fh'}, Fcntl::LOCK_UN();
92 0         0 return $v;
93             } elsif ($prop->{'serialize'} eq 'semaphore') {
94 0 0       0 $prop->{'sem'}->op(0, -1, IPC::SysV::SEM_UNDO()) or $self->fatal("Semaphore Error [$!]");
95 0         0 my $v = $self->super_accept();
96 0 0       0 $prop->{'sem'}->op(0, 1, IPC::SysV::SEM_UNDO()) or $self->fatal("Semaphore Error [$!]");
97 0         0 return $v;
98             } elsif ($prop->{'serialize'} eq 'pipe') {
99 0         0 my $waiting = $prop->{'_WAITING'};
100 0         0 scalar <$waiting>; # read one line - kernel says who gets it
101 0         0 my $v = $self->super_accept();
102 0         0 print { $prop->{'_READY'} } "Next!\n";
  0         0  
103 0         0 return $v;
104             } else {
105 0         0 my $v = $self->super_accept();
106 0         0 return $v;
107             }
108             }
109              
110              
111             sub super_accept {
112 0     0 1 0 my $self = shift;
113 0         0 my $prop = $self->{'server'};
114              
115 0         0 my $sock = undef;
116 0         0 my $retries = 30;
117 0         0 while ($retries--) {
118 0 0       0 if ($prop->{'multi_port'}) { # with more than one port, use select to get the next one
119 0 0       0 return 0 if $prop->{'_HUP'};
120 0         0 ($sock, my $hup) = $self->accept_multi_port; # keep trying for the rest of retries
121 0 0 0     0 return 0 if $hup || $prop->{'_HUP'};
122 0 0       0 if ($self->can_read_hook($sock)) {
123 0         0 $retries++;
124 0         0 next;
125             }
126             } else {
127 0         0 $sock = $prop->{'sock'}->[0]; # single port is bound - just accept
128             }
129 0 0       0 $self->fatal("Received a bad sock!") if ! defined $sock;
130              
131 0 0       0 if (SOCK_DGRAM == $sock->getsockopt(Socket::SOL_SOCKET(), Socket::SO_TYPE())) { # receive a udp packet
132 0         0 $prop->{'client'} = $sock;
133 0         0 $prop->{'udp_true'} = 1;
134 0         0 $prop->{'udp_peer'} = $sock->recv($prop->{'udp_data'}, $sock->NS_recv_len, $sock->NS_recv_flags);
135              
136             } else { # blocking accept per proto
137 0         0 delete $prop->{'udp_true'};
138 0         0 $prop->{'client'} = $sock->accept();
139             }
140              
141 0 0       0 return 0 if $prop->{'_HUP'};
142 0 0       0 return 1 if $prop->{'client'};
143              
144 0         0 $self->log(2,"Accept failed with $retries tries left: $!");
145 0         0 sleep(1);
146             }
147              
148 0         0 $self->log(1,"Ran out of accept retries!");
149 0         0 return undef; ## no critic
150             }
151              
152              
153             sub accept_multi_port {
154 92     92 0 432926560 my $self = shift;
155              
156 92   33     1305 my $config = $self->{config} || get_config();
157 92 50       1571 return $self->SUPER unless $config->{'patch_net_server'};
158              
159 0           my $prop = $self->{'server'};
160 0           while (1) {
161 0           my @waiting = $prop->{'select'}->can_read();
162 0 0 0       next if !@waiting && $! == EINTR;
163 0 0         return (undef, 1) if grep { fileno($_) == fileno($prop->{'SigHUPReadPipe'}) } @waiting;
  0            
164 0 0         return (undef, 0) if ! @waiting;
165 0           return ($waiting[rand @waiting], 0);
166             }
167             }
168              
169             1;
170              
171             __END__
172              
173             =pod
174              
175             =encoding UTF-8
176              
177             =head1 NAME
178              
179             Mail::Milter::Authentication::Net::ServerPatches - Patches to Net::Server::PreFork
180              
181             =head1 VERSION
182              
183             version 3.20230911
184              
185             =head1 METHODS
186              
187             =head2 I<run_child()>
188              
189             Patches to the Net::Server run_child method
190              
191             =head2 I<accept()>
192              
193             Patches to the Net::Server accept method
194              
195             =head2 I<super_accept()>
196              
197             Patches to the Net::Server accept method
198              
199             =head2 I<accep_multi_portt()>
200              
201             Patches to the Net::Server accept_multi_port method
202              
203             =head1 AUTHOR
204              
205             Marc Bradshaw <marc@marcbradshaw.net>
206              
207             =head1 COPYRIGHT AND LICENSE
208              
209             This software is copyright (c) 2020 by Marc Bradshaw.
210              
211             This is free software; you can redistribute it and/or modify it under
212             the same terms as the Perl 5 programming language system itself.
213              
214             =cut