File Coverage

blib/lib/Net/Server/PreFork.pm
Criterion Covered Total %
statement 131 263 49.8
branch 37 128 28.9
condition 9 32 28.1
subroutine 17 30 56.6
pod 7 15 46.6
total 201 468 42.9


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::PreFork - Net::Server personality
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::PreFork;
19              
20 2     2   15056 use strict;
  2         6  
  2         70  
21 2     2   28 use base qw(Net::Server::PreForkSimple);
  2         4  
  2         1084  
22 2     2   12 use Net::Server::SIG qw(register_sig check_sigs);
  2         4  
  2         76  
23 2     2   12 use POSIX qw(WNOHANG);
  2         2  
  2         8  
24 2     2   90 use IO::Select ();
  2         4  
  2         28  
25 2     2   800 use Time::HiRes qw(time);
  2         2624  
  2         8  
26              
27 1     1 0 3 sub net_server_type { __PACKAGE__ }
28              
29             sub options {
30 1     1 0 2 my $self = shift;
31 1         34 my $ref = $self->SUPER::options(@_);
32 1         2 my $prop = $self->{'server'};
33 1         20 $ref->{$_} = \$prop->{$_} for qw(min_servers min_spare_servers max_spare_servers spare_servers
34             check_for_waiting child_communication check_for_spawn min_child_ttl);
35 1         8 return $ref;
36             }
37              
38              
39             sub post_configure {
40 1     1 1 3 my $self = shift;
41 1         1 my $prop = $self->{'server'};
42 1         28 $self->SUPER::post_configure;
43              
44 1         5 my $d = {
45             # max_servers is set in the PreForkSimple server and defaults to 50
46             min_servers => 5, # min num of servers to always have running
47             min_spare_servers => 2, # min num of servers just sitting there
48             max_spare_servers => 10, # max num of servers just sitting there
49             check_for_waiting => 10, # how often to see if children laying around
50             check_for_spawn => 30, # how often to see if more children are needed
51             min_child_ttl => 10, # min time between starting a child and killing one
52             };
53             $prop->{'min_servers'} = $prop->{'max_servers'}
54 1 50 33     12 if !!defined($prop->{'min_servers'}) && $d->{'min_servers'} > $prop->{'max_servers'};
55             $prop->{'max_spare_servers'} = $prop->{'max_servers'} - 1
56 1 50 33     6 if !defined($prop->{'max_spare_servers'}) && $d->{'max_spare_servers'} >= $prop->{'max_servers'};
57 1 50       2 if (! defined $prop->{'min_spare_servers'}) {
58 0 0       0 my $min = defined($prop->{'min_servers'}) ? $prop->{'min_servers'} : $d->{'min_servers'};
59 0 0       0 $prop->{'min_spare_servers'} = $min if $prop > $min;
60             }
61              
62 1         3 foreach (keys %$d){
63 6 100 66     36 $prop->{$_} = $d->{$_} if !defined($prop->{$_}) || $prop->{$_} !~ /^\d+(?:\.\d+)?$/;
64             }
65              
66 1 50       6 if( $prop->{'max_spare_servers'} >= $prop->{'max_servers'} ){
67 0         0 $self->fatal("Error: \"max_spare_servers\" must be less than \"max_servers\"");
68             }
69              
70 1 50       10 if ($prop->{'min_spare_servers'}) {
71             $self->fatal("Error: \"min_spare_servers\" ($prop->{'min_spare_servers'}) must be less than \"$_\" ($prop->{$_})")
72 0         0 for grep {$prop->{'min_spare_servers'} > $prop->{$_}} qw(min_servers max_spare_servers);
  0         0  
73             }
74             }
75              
76              
77             sub loop {
78 1     1 1 3 my $self = shift;
79 1         2 my $prop = $self->{'server'};
80              
81 1         27 pipe(my $read, my $write); # get ready for child->parent communication
82 1         9 $read->autoflush(1);
83 1         35 $write->autoflush(1);
84 1         23 $prop->{'_READ'} = $read;
85 1         3 $prop->{'_WRITE'} = $write;
86              
87             # get ready for children
88 1         4 $prop->{'child_select'} = IO::Select->new($read);
89 1         56 $prop->{'children'} = {};
90 1         4 $prop->{'reaped_children'} = {};
91 1 50       9 if ($ENV{'HUP_CHILDREN'}) {
92 0         0 foreach my $line (split /\n/, $ENV{'HUP_CHILDREN'}) {
93 0 0       0 my ($pid, $status) = ($line =~ /^(\d+)\t(\w+)$/) ? ($1, $2) : next;
94 0         0 $prop->{'children'}->{$pid} = {status => $status, hup => 1};
95             }
96             }
97              
98             $prop->{'tally'} = {
99             time => time(),
100 0         0 waiting => scalar(grep {$_->{'status'} eq 'waiting'} values %{ $prop->{'children'} }),
  1         4  
101 0         0 processing => scalar(grep {$_->{'status'} eq 'processing'} values %{ $prop->{'children'} }),
  1         2  
102 1         13 dequeue => scalar(grep {$_->{'status'} eq 'dequeue'} values %{ $prop->{'children'} }),
  0         0  
  1         30  
103             };
104              
105 1         4 my $start = $prop->{'min_servers'};
106 1         6 $self->log(3, "Beginning prefork ($start processes)");
107 1         22 $self->run_n_children($start);
108              
109 1         25 $self->run_parent;
110             }
111              
112              
113             sub kill_n_children {
114 0     0 0 0 my ($self, $n) = @_;
115 0         0 my $prop = $self->{'server'};
116 0 0       0 return unless $n > 0;
117              
118 0         0 my $time = time;
119 0 0       0 return unless $time - $prop->{'last_kill'} > 10;
120 0         0 $prop->{'last_kill'} = $time;
121              
122 0         0 $self->log(3, "Killing \"$n\" children");
123              
124 0         0 foreach my $pid (keys %{ $prop->{'children'} }){
  0         0  
125             # Only kill waiting children
126             # XXX: This is race condition prone as the child may have
127             # started handling a connection, but will have to do for now
128 0         0 my $child = $prop->{'children'}->{$pid};
129 0 0       0 next if $child->{'status'} ne 'waiting';
130              
131 0         0 $n--;
132              
133 0 0       0 if (! kill('HUP', $pid)) {
134 0         0 $self->delete_child($pid);
135             }
136              
137 0 0       0 last if $n <= 0;
138             }
139             }
140              
141             sub run_n_children {
142 1     1 0 3 my ($self, $n) = @_;
143 1         8 my $prop = $self->{'server'};
144 1 50       5 return unless $n > 0;
145              
146 1         13 $self->run_n_children_hook($n);
147              
148 1         2 my ($parentsock, $childsock);
149 1         4 $self->log(3, "Starting \"$n\" children");
150 1         4 $prop->{'last_start'} = time();
151              
152 1         3 for (1 .. $n) {
153              
154 1 50       3 if ($prop->{'child_communication'}) {
155 1         5 require IO::Socket::UNIX;
156 1         54 ($parentsock, $childsock) = IO::Socket::UNIX->socketpair(IO::Socket::AF_UNIX, IO::Socket::SOCK_STREAM, IO::Socket::PF_UNSPEC);
157             }
158              
159 1         224 $self->pre_fork_hook;
160 1         19 local $!;
161 1         893 my $pid = fork;
162 1 50       42 if (! defined $pid) {
163 0 0       0 if ($prop->{'child_communication'}) {
164 0         0 $parentsock->close();
165 0         0 $childsock->close();
166             }
167 0         0 $self->fatal("Bad fork [$!]");
168             }
169              
170 1 50       39 if ($pid) { # parent
171 1 50       31 if( $prop->{'child_communication'} ){
172 1         61 $prop->{'child_select'}->add($parentsock);
173 1         152 $prop->{'children'}->{$pid}->{'sock'} = $parentsock;
174             }
175              
176 1         18 $prop->{'children'}->{$pid}->{'status'} = 'waiting';
177 1         9 $prop->{'tally'}->{'waiting'}++;
178 1         57 $self->register_child($pid, 'prefork');
179              
180             } else { # child
181 0 0       0 if ($prop->{'child_communication'}) {
182 0         0 $prop->{'parent_sock'} = $childsock;
183             }
184 0         0 $self->run_child;
185             }
186             }
187             }
188              
189       1 1   sub run_n_children_hook {}
190              
191             sub run_child {
192 0     0 0 0 my $self = shift;
193 0         0 my $prop = $self->{'server'};
194              
195             $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = sub {
196 0     0   0 $self->child_finish_hook;
197 0         0 exit;
198 0         0 };
199 0         0 $SIG{'PIPE'} = 'IGNORE';
200 0         0 $SIG{'CHLD'} = 'DEFAULT';
201             $SIG{'HUP'} = sub {
202 0 0   0   0 if (! $prop->{'connected'}) {
203 0         0 $self->child_finish_hook;
204 0         0 exit;
205             }
206 0         0 $prop->{'SigHUPed'} = 1;
207 0         0 };
208              
209             # Open in child at start
210 0 0       0 if ($prop->{'serialize'} eq 'flock') {
211 0 0       0 open $prop->{'lock_fh'}, ">", $prop->{'lock_file'}
212             or $self->fatal("Couldn't open lock file \"$prop->{'lock_file'}\"[$!]");
213             }
214              
215 0         0 $self->log(4, "Child Preforked ($$)");
216              
217 0         0 delete @{ $prop }{qw(children tally last_start last_process)};
  0         0  
218              
219 0         0 $self->child_init_hook;
220 0         0 my $write = $prop->{'_WRITE'};
221              
222 0         0 while ($self->accept()) {
223 0         0 $prop->{'connected'} = 1;
224 0         0 print $write "$$ processing\n";
225              
226 0         0 my $ok = eval { $self->run_client_connection; 1 };
  0         0  
  0         0  
227 0 0       0 if (! $ok) {
228 0         0 print $write "$$ exiting\n";
229 0         0 die $@;
230             }
231              
232 0 0       0 last if $self->done;
233              
234 0         0 $prop->{'connected'} = 0;
235 0         0 print $write "$$ waiting\n";
236             }
237              
238 0         0 $self->child_finish_hook;
239              
240 0         0 print $write "$$ exiting\n";
241 0         0 exit;
242             }
243              
244              
245             sub run_parent {
246 1     1 0 5 my $self = shift;
247 1         12 my $prop = $self->{'server'};
248 1         3 my $id;
249              
250 1         27 $self->log(4, "Parent ready for children.");
251 1         3 my $read_fh = $prop->{'_READ'};
252              
253 1         10 @{ $prop }{qw(last_checked_for_dead last_checked_for_waiting last_checked_for_dequeue last_process last_kill)} = (time) x 5;
  1         41  
254              
255             my $reaper = sub {
256 0     0   0 while ( defined( my $chld = waitpid( -1, WNOHANG ) ) ) {
257 0 0       0 last unless $chld > 0;
258 0         0 $self->{'reaped_children'}->{$chld} = $?
259             ; # We'll deal with this in coordinate_children to avoid a race
260             }
261 1         14 };
262              
263             register_sig(
264             PIPE => 'IGNORE',
265 1     1   25 INT => sub { $self->server_close() },
266 0     0   0 TERM => sub { $self->server_close() },
267 0     0   0 HUP => sub { $self->sig_hup() },
268             CHLD => $reaper,
269 0     0   0 QUIT => sub { $self->{'server'}->{'kind_quit'} = 1; $self->server_close() },
  0         0  
270 0     0   0 TTIN => sub { $self->{'server'}->{$_}++ for qw(min_servers max_servers); $self->log(3, "Increasing server count ($self->{'server'}->{'max_servers'})") },
  0         0  
271 0     0   0 TTOU => sub { $self->{'server'}->{$_}-- for qw(min_servers max_servers); $self->log(3, "Decreasing server count ($self->{'server'}->{'max_servers'})") },
  0         0  
272 1         132 );
273              
274 1         22 $self->register_sig_pass;
275              
276 1 50       7 if ($ENV{'HUP_CHILDREN'}) {
277 0         0 $reaper->();
278             }
279              
280 1         2 while (1) {
281             ### Wait to read.
282             ## Normally it is not good to do selects with
283             ## getline or <$fh> but this is controlled output
284             ## where everything that comes through came from us.
285 4         21 my @fh = $prop->{'child_select'}->can_read($prop->{'check_for_waiting'});
286 4 50       3117 if (check_sigs()) {
287 0 0       0 last if $prop->{'_HUP'};
288             }
289              
290 3         25 $self->idle_loop_hook(\@fh);
291              
292 3 50       8 if (! @fh) {
293 0         0 $self->coordinate_children();
294 0         0 next;
295             }
296              
297 3         5 foreach my $fh (@fh) {
298 3 50       7 if ($fh != $read_fh) { # preforking server data
299 0         0 $self->child_is_talking_hook($fh);
300 0         0 next;
301             }
302              
303 3         45 my $line = <$fh>;
304 3 50       11 next if ! defined $line;
305              
306 3 50       22 last if $self->parent_read_hook($line); # optional test by user hook
307              
308             # child should say "$pid status\n"
309 3 50       28 next if $line !~ /^(\d+)\ +(waiting|processing|dequeue|exiting)$/;
310 3         36 my ($pid, $status) = ($1, $2);
311              
312 3 50       13 if (my $child = $prop->{'children'}->{$pid}) {
313 3 50       8 if ($status eq 'exiting') {
314 0         0 $self->delete_child($pid);
315              
316             } else {
317             # Decrement tally of state pid was in (plus sanity check)
318 3   33     12 my $old_status = $child->{'status'} || $self->log(2, "No status for $pid when changing to $status");
319 3 50       13 --$prop->{'tally'}->{$old_status} >= 0 || $self->log(2, "Tally for $status < 0 changing pid $pid from $old_status to $status");
320              
321 3         6 $child->{'status'} = $status;
322 3         5 ++$prop->{'tally'}->{$status};
323              
324 3 100       12 $prop->{'last_process'} = time() if $status eq 'processing';
325             }
326             }
327             }
328 3         16 $self->coordinate_children();
329             }
330             }
331              
332             sub run_dequeue {
333 0     0 1 0 my $self = shift;
334 0         0 $self->SUPER::run_dequeue;
335 0         0 $self->{'server'}->{'tally'}->{'dequeue'}++;
336             }
337              
338 0     0 1 0 sub cleanup_dead_child_hook { return; }
339              
340             sub coordinate_children {
341 3     3 0 5 my $self = shift;
342 3         5 my $prop = $self->{'server'};
343 3         12 my $time = time();
344              
345             # deleted SIG{'CHLD'} reaped children
346 3         5 foreach my $pid (keys %{ $self->{'reaped_children'} }) {
  3         24  
347 0         0 my $exit = delete $self->{'reaped_children'}->{$pid}; # delete each pid one by one to avoid another race
348 0 0       0 next if ! $prop->{'children'}->{$pid};
349 0         0 $self->delete_child($pid, $exit);
350             }
351              
352             # re-tally the possible types (only twice a minute)
353             # this might not be even necessary but is a nice sanity check
354 3   50     8 my $tally = $prop->{'tally'} ||= {};
355 3 50       9 if ($time - $tally->{'time'} > $prop->{'check_for_spawn'}) {
356 0         0 my $w = $tally->{'waiting'};
357 0         0 my $p = $tally->{'processing'};
358 0         0 $tally = $prop->{'tally'} = {
359             time => $time,
360             waiting => 0,
361             processing => 0,
362             dequeue => 0,
363             };
364 0         0 foreach (values %{ $prop->{'children'} }) {
  0         0  
365 0         0 $tally->{$_->{'status'}}++;
366             }
367 0         0 $w -= $tally->{'waiting'};
368 0         0 $p -= $tally->{'processing'};
369 0 0 0     0 $self->log(3, "Processing diff ($p), Waiting diff ($w)") if $p || $w;
370             }
371              
372 3         7 my $total = $tally->{'waiting'} + $tally->{'processing'};
373              
374 3 50 33     11 if ($total < $prop->{'min_servers'}) {
    50          
375 0         0 $self->run_n_children($prop->{'min_servers'} - $total); # need more min_servers
376              
377             } elsif ($tally->{'waiting'} < $prop->{'min_spare_servers'}
378             && $total < $prop->{'max_servers'}) { # need more min_spare_servers (up to max_servers)
379 0         0 my $n1 = $prop->{'min_spare_servers'} - $tally->{'waiting'};
380 0         0 my $n2 = $prop->{'max_servers'} - $total;
381 0 0       0 $self->run_n_children(($n2 > $n1) ? $n1 : $n2);
382             }
383              
384             # check to see if we should kill off some children
385 3 50       6 if ($time - $prop->{'last_checked_for_waiting'} > $prop->{'check_for_waiting'}) {
386 0         0 $prop->{'last_checked_for_waiting'} = $time;
387              
388             # need fewer max_spare_servers (down to min_servers)
389 0 0 0     0 if ($tally->{'waiting'} > $prop->{'max_spare_servers'}
    0          
390             && $total > $prop->{'min_servers'}) {
391              
392             ### see if we haven't started any in the last ten seconds
393 0 0       0 if ($time - $prop->{'last_start'} > $prop->{'min_child_ttl'}) {
394 0         0 my $n1 = $tally->{'waiting'} - $prop->{'max_spare_servers'};
395 0         0 my $n2 = $total - $prop->{'min_servers'};
396 0 0       0 $self->kill_n_children(($n2 > $n1) ? $n1 : $n2);
397             }
398              
399             } elsif ($total > $prop->{'max_servers'}) { # how did this happen?
400 0         0 $self->kill_n_children($total - $prop->{'max_servers'});
401             }
402             }
403              
404             # periodically make sure children are alive
405 3 50       12 if ($time - $prop->{'last_checked_for_dead'} > $prop->{'check_for_dead'}) {
406 0         0 $prop->{'last_checked_for_dead'} = $time;
407 0         0 foreach my $pid (keys %{ $prop->{'children'} }) {
  0         0  
408 0 0       0 if( ! kill(0, $pid) ) {
409 0         0 $self->cleanup_dead_child_hook( $prop->{'children'}->{$pid} );
410 0         0 $self->delete_child($pid);
411             }
412             }
413             }
414              
415             # take us down to min if we haven't had a request in a while
416 3 50 33     13 if ($time - $prop->{'last_process'} > 30 && $tally->{'waiting'} > $prop->{'min_spare_servers'}) {
417 0         0 my $n1 = $tally->{'waiting'} - $prop->{'min_spare_servers'};
418 0         0 my $n2 = $total - $prop->{'min_servers'};
419 0 0       0 $self->kill_n_children( ($n2 > $n1) ? $n1 : $n2 );
420             }
421              
422             # periodically check to see if we should clear the queue
423 3 50       8 if (defined $prop->{'check_for_dequeue'}) {
424 0 0       0 if ($time - $prop->{'last_checked_for_dequeue'} > $prop->{'check_for_dequeue'}) {
425 0         0 $prop->{'last_checked_for_dequeue'} = $time;
426 0 0 0     0 if (defined($prop->{'max_dequeue'})
427             && $tally->{'dequeue'} < $prop->{'max_dequeue'}) {
428 0         0 $self->run_dequeue();
429             }
430             }
431             }
432             }
433              
434             ### delete_child and other modifications contributed by Rob Mueller
435             sub delete_child {
436 1     1 0 4 my ($self, $pid, $exit) = @_;
437 1         3 my $prop = $self->{'server'};
438              
439 1         2 my $child = $prop->{'children'}->{$pid};
440 1 50       4 if (! $child) {
441 0         0 $self->log(2, "Attempt to delete already deleted child $pid");
442 0         0 return;
443             }
444              
445 1 50       3 return if ! exists $prop->{'children'}->{$pid}; # Already gone?
446              
447             # This means there was some sort of abnormal exit for the child, like a
448             # segfault.
449 1 50       3 if ($exit) {
450 0         0 my $status = $exit >> 8;
451 0         0 my $signal = $exit & 127;
452 0         0 my $message = "Child process $pid exited with status $status";
453 0 0       0 $message .= " - signal was $signal"
454             if $signal;
455              
456 0         0 $self->log(1, $message);
457             }
458              
459 1   33     11 my $status = $child->{'status'} || $self->log(2, "No status for $pid when deleting child");
460 1 50       5 --$prop->{'tally'}->{$status} >= 0 || $self->log(2, "Tally for $status < 0 deleting pid $pid");
461 1 50       2 $prop->{'tally'}->{'time'} = 0 if $child->{'hup'};
462              
463 1         14 $self->SUPER::delete_child($pid);
464             }
465              
466       3 1   sub parent_read_hook {}
467              
468       0 1   sub child_is_talking_hook {}
469              
470             1;
471              
472             __END__