File Coverage

blib/lib/Net/Server/PreForkSimple.pm
Criterion Covered Total %
statement 113 200 56.5
branch 24 94 25.5
condition 5 18 27.7
subroutine 21 29 72.4
pod 5 14 35.7
total 168 355 47.3


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::PreForkSimple - Net::Server personality
4             #
5             # Copyright (C) 2001-2017
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::PreForkSimple;
19              
20 5     5   16911 use strict;
  5         10  
  5         148  
21 5     5   22 use base qw(Net::Server);
  5         19  
  5         1990  
22 5     5   2405 use File::Temp qw(tempfile);
  5         37615  
  5         269  
23 5     5   1496 use Net::Server::SIG qw(register_sig check_sigs);
  5         12  
  5         253  
24 5     5   27 use POSIX qw(WNOHANG EINTR);
  5         10  
  5         22  
25 5     5   281 use Fcntl ();
  5         10  
  5         8931  
26              
27 2     2 0 6 sub net_server_type { __PACKAGE__ }
28              
29             sub options {
30 3     3 0 8 my $self = shift;
31 3         118 my $ref = $self->SUPER::options(@_);
32 3         13 my $prop = $self->{'server'};
33              
34 3         69 $ref->{$_} = \$prop->{$_} for qw(max_servers max_requests max_dequeue
35             check_for_dead check_for_dequeue
36             lock_file serialize);
37 3         17 $ref->{'sig_passthrough'} = $prop->{'sig_passthrough'} = [];
38 3         12 return $ref;
39             }
40              
41             sub post_configure {
42 3     3 1 9 my $self = shift;
43 3         10 my $prop = $self->{'server'};
44 3         56 $self->SUPER::post_configure;
45              
46             ### some default values to check for
47 3         13 my $d = {
48             max_servers => 50, # max num of servers to run
49             max_requests => 1000, # num of requests for each child to handle
50             check_for_dead => 30, # how often to see if children are alive
51             };
52 3         16 foreach (keys %$d){
53             $prop->{$_} = $d->{$_}
54 9 100 66     93 unless defined($prop->{$_}) && $prop->{$_} =~ /^\d+$/;
55             }
56              
57 3         73 $prop->{'ppid'} = $$;
58             }
59              
60              
61             sub post_bind {
62 3     3 1 8 my $self = shift;
63 3         9 my $prop = $self->{'server'};
64 3         51 $self->SUPER::post_bind;
65              
66 3 50 33     34 if ($prop->{'multi_port'} && $prop->{'serialize'} && $prop->{'serialize'} eq 'none') {
      33        
67 0         0 $self->log(2, "Passed serialize value of none is incompatible with multiple ports - using default serialize");
68 0         0 delete $prop->{'serialize'};
69             }
70 3 50 33     16 if (!$prop->{'serialize'}
71             || $prop->{'serialize'} !~ /^(flock|semaphore|pipe|none)$/i) {
72 3 50       27 $prop->{'serialize'} = ($^O eq 'MSWin32') ? 'pipe' : 'flock';
73             }
74 3         14 $prop->{'serialize'} =~ tr/A-Z/a-z/;
75              
76 3 50       16 if ($prop->{'serialize'} eq 'flock') {
    0          
    0          
    0          
77 3         21 $self->log(3, "Setting up serialization via flock");
78 3 50       19 if (defined $prop->{'lock_file'}) {
79 0         0 $prop->{'lock_file_unlink'} = undef;
80             } else {
81 3         64 (my $fh, $prop->{'lock_file'}) = tempfile();
82             # We don't need to keep the file handle open in the parent;
83             # each child opens it separately to avoid sharing the lock
84 3 50       2859 close $fh or die "Cannot close lock file $prop->{'lock_file'}: $!";
85 3         28 $prop->{'lock_file_unlink'} = 1;
86             }
87              
88             } elsif ($prop->{'serialize'} eq 'semaphore') {
89 0         0 $self->log(3, "Setting up serialization via semaphore");
90 0         0 require IPC::SysV;
91 0         0 require IPC::Semaphore;
92 0 0       0 my $s = IPC::Semaphore->new(IPC::SysV::IPC_PRIVATE(), 1, IPC::SysV::S_IRWXU() | IPC::SysV::IPC_CREAT())
93             or $self->fatal("Semaphore error [$!]");
94 0 0       0 $s->setall(1) or $self->fatal("Semaphore create error [$!]");
95 0         0 $prop->{'sem'} = $s;
96              
97             } elsif ($prop->{'serialize'} eq 'pipe') {
98 0         0 $self->log(3, "Setting up serialization via pipe");
99 0         0 pipe(my $waiting, my $ready);
100 0         0 $ready->autoflush(1);
101 0         0 $waiting->autoflush(1);
102 0         0 $prop->{'_READY'} = $ready;
103 0         0 $prop->{'_WAITING'} = $waiting;
104 0         0 print $ready "First\n";
105             } elsif ($prop->{'serialize'} eq 'none') {
106 0         0 $self->log(3, "Using no serialization");
107             } else {
108 0         0 $self->fatal("Unknown serialization type \"$prop->{'serialize'}\"");
109             }
110              
111             }
112              
113             sub loop {
114 2     2 1 6 my $self = shift;
115 2         8 my $prop = $self->{'server'};
116              
117 2         16 $prop->{'children'} = {};
118 2 50       14 if ($ENV{'HUP_CHILDREN'}) {
119 0         0 my %children = map {/^(\w+)$/; $1} split(/\s+/, $ENV{'HUP_CHILDREN'});
  0         0  
  0         0  
120 0         0 $children{$_} = {status => $children{$_}, hup => 1} foreach keys %children;
121 0         0 $prop->{'children'} = \%children;
122             }
123              
124 2         18 $self->log(3, "Beginning prefork ($prop->{'max_servers'} processes)");
125              
126 2         18 $self->run_n_children($prop->{'max_servers'});
127              
128 1         70 $self->run_parent;
129              
130             }
131              
132             sub run_n_children {
133 2     2 0 8 my ($self, $n) = @_;
134 2 50       8 return if $n <= 0;
135 2         6 my $prop = $self->{'server'};
136              
137 2         14 $self->run_n_children_hook;
138              
139 2         12 $self->log(3, "Starting \"$n\" children");
140              
141 2         10 for (1 .. $n) {
142 3         94 $self->pre_fork_hook;
143 3         58 local $!;
144 3         2213 my $pid = fork;
145 3 50       109 $self->fatal("Bad fork [$!]") if ! defined $pid;
146              
147 3 100       73 if ($pid) {
148 2         148 $prop->{'children'}->{$pid}->{'status'} = 'processing';
149             } else {
150 1         57 $self->run_child;
151             }
152             }
153             }
154              
155       2 1   sub run_n_children_hook {}
156              
157             sub run_child {
158 1     1 0 12 my $self = shift;
159 1         9 my $prop = $self->{'server'};
160              
161             $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = sub {
162 1     1   14 $self->child_finish_hook;
163 1         95 exit;
164 1         46 };
165 1         42 $SIG{'PIPE'} = 'IGNORE';
166 1         6 $SIG{'CHLD'} = 'DEFAULT';
167             $SIG{'HUP'} = sub {
168 0 0   0   0 if (! $prop->{'connected'}) {
169 0         0 $self->child_finish_hook;
170 0         0 exit;
171             }
172 0         0 $prop->{'SigHUPed'} = 1;
173 1         13 };
174              
175 1 50       12 my $needs_lock = ($prop->{'serialize'} eq 'flock') ? 1 : 0;
176 1 50       6 if ($needs_lock) {
177 1 50       94 open($prop->{'lock_fh'}, ">", $prop->{'lock_file'})
178             or $self->fatal("Couldn't open lock file \"$prop->{'lock_file'}\"[$!]");
179             }
180              
181 1         54 $self->log(4, "Child Preforked ($$)");
182 1         11 delete $prop->{'children'};
183              
184 1         22 $self->child_init_hook;
185              
186 1         16 while ($self->accept()) {
187 1         6 $prop->{'connected'} = 1;
188 1         29 $self->run_client_connection;
189 1         2 $prop->{'connected'} = 0;
190 1 50       7 last if $self->done;
191             }
192              
193 0         0 $self->child_finish_hook;
194              
195 0 0 0     0 close($prop->{'lock_fh'}) if $needs_lock && $prop->{'lock_fh'};
196              
197 0         0 $self->log(4, "Child leaving ($prop->{'max_requests'})");
198 0         0 exit;
199              
200             }
201              
202 0     0 0 0 sub is_prefork { 1 }
203              
204             ### We can only let one process do the selecting at a time
205             ### this override makes sure that nobody else can do it
206             ### while we are. We do this either by opening a lock file
207             ### and getting an exclusive lock (this will block all others
208             ### until we release it) or by using semaphores to block
209             sub accept {
210 2     2 0 131 my $self = shift;
211 2         8 my $prop = $self->{'server'};
212              
213 2 50       9 if ($prop->{'serialize'} eq 'flock') {
    0          
    0          
214 2         2573 while (! flock $prop->{'lock_fh'}, Fcntl::LOCK_EX()) {
215 0 0       0 next if $! == EINTR;
216 0         0 $self->fatal("Couldn't get lock on file \"$prop->{'lock_file'}\" [$!]");
217             }
218 1         16 my $v = $self->SUPER::accept();
219 1         10 flock $prop->{'lock_fh'}, Fcntl::LOCK_UN();
220 1         4 return $v;
221             } elsif ($prop->{'serialize'} eq 'semaphore') {
222 0 0       0 $prop->{'sem'}->op(0, -1, IPC::SysV::SEM_UNDO()) or $self->fatal("Semaphore Error [$!]");
223 0         0 my $v = $self->SUPER::accept();
224 0 0       0 $prop->{'sem'}->op(0, 1, IPC::SysV::SEM_UNDO()) or $self->fatal("Semaphore Error [$!]");
225 0         0 return $v;
226             } elsif ($prop->{'serialize'} eq 'pipe') {
227 0         0 my $waiting = $prop->{'_WAITING'};
228 0         0 scalar <$waiting>; # read one line - kernel says who gets it
229 0         0 my $v = $self->SUPER::accept();
230 0         0 print { $prop->{'_READY'} } "Next!\n";
  0         0  
231 0         0 return $v;
232             } else {
233 0         0 my $v = $self->SUPER::accept();
234 0         0 return $v;
235             }
236             }
237              
238             sub done {
239 1     1 0 2 my $self = shift;
240 1         3 my $prop = $self->{'server'};
241 1 50       4 $prop->{'done'} = shift if @_;
242 1 50       2 return 1 if $prop->{'done'};
243 1 50       3 return 1 if $prop->{'requests'} >= $prop->{'max_requests'};
244 1 50       2 return 1 if $prop->{'SigHUPed'};
245 1 50       15 if (! kill 0, $prop->{'ppid'}) {
246 0         0 $self->log(3, "Parent process gone away. Shutting down");
247 0         0 return 1;
248             }
249             }
250              
251             sub run_parent {
252 1     1 0 8 my $self=shift;
253 1         4 my $prop = $self->{'server'};
254              
255 1         47 $self->log(4, "Parent ready for children.");
256              
257 1         17 $prop->{'last_checked_for_dead'} = $prop->{'last_checked_for_dequeue'} = time();
258              
259             register_sig(
260             PIPE => 'IGNORE',
261 1     1   23 INT => sub { $self->server_close() },
262 0     0   0 TERM => sub { $self->server_close() },
263 0     0   0 HUP => sub { $self->sig_hup() },
264             CHLD => sub {
265 0     0   0 while (defined(my $chld = waitpid(-1, WNOHANG))) {
266 0 0       0 last unless $chld > 0;
267 0         0 $self->delete_child($chld);
268             }
269             },
270 0     0   0 QUIT => sub { $self->{'server'}->{'kind_quit'} = 1; $self->server_close() },
  0         0  
271 0     0   0 TTIN => sub { $self->{'server'}->{'max_servers'}++; $self->log(3, "Increasing max server count ($self->{'server'}->{'max_servers'})") },
  0         0  
272             TTOU => sub {
273 0     0   0 $self->{'server'}->{'max_servers'}--;
274 0         0 $self->log(3, "Decreasing max server count ($self->{'server'}->{'max_servers'})");
275 0 0       0 if (defined(my $pid = each %{ $prop->{'children'} })) {
  0         0  
276 0 0       0 $self->delete_child($pid) if ! kill('HUP', $pid);
277             }
278             },
279 1         90 );
280              
281 1         37 $self->register_sig_pass;
282              
283 1 50       5 if ($ENV{'HUP_CHILDREN'}) {
284 0         0 while (defined(my $chld = waitpid(-1, WNOHANG))) {
285 0 0       0 last unless $chld > 0;
286 0         0 $self->delete_child($chld);
287             }
288             }
289              
290 1         3 while (1) {
291 1         3052 select undef, undef, undef, 10;
292              
293 1 0       23 if (check_sigs()){
294 0 0       0 last if $prop->{'_HUP'};
295             }
296              
297 0         0 $self->idle_loop_hook();
298              
299             # periodically make sure children are alive
300 0         0 my $time = time();
301 0 0       0 if ($time - $prop->{'last_checked_for_dead'} > $prop->{'check_for_dead'}) {
302 0         0 $prop->{'last_checked_for_dead'} = $time;
303 0         0 foreach (keys %{ $prop->{'children'} }) {
  0         0  
304 0 0       0 kill(0,$_) or $self->delete_child($_);
305             }
306             }
307              
308             # make sure we always have max_servers
309 0         0 my $total_n = 0;
310 0         0 my $total_d = 0;
311 0         0 foreach (values %{ $prop->{'children'} }){
  0         0  
312 0 0       0 if( $_->{'status'} eq 'dequeue' ){
313 0         0 $total_d ++;
314             }else{
315 0         0 $total_n ++;
316             }
317             }
318              
319 0 0       0 if( $prop->{'max_servers'} > $total_n ){
320 0         0 $self->run_n_children( $prop->{'max_servers'} - $total_n );
321             }
322              
323             # periodically check to see if we should clear the queue
324 0 0       0 if( defined $prop->{'check_for_dequeue'} ){
325 0 0       0 if( $time - $prop->{'last_checked_for_dequeue'}
326             > $prop->{'check_for_dequeue'} ){
327 0         0 $prop->{'last_checked_for_dequeue'} = $time;
328 0 0 0     0 if( defined($prop->{'max_dequeue'})
329             && $total_d < $prop->{'max_dequeue'} ){
330 0         0 $self->run_dequeue();
331             }
332             }
333             }
334              
335             }
336             }
337              
338       3 1   sub idle_loop_hook {}
339              
340             sub close_children {
341 2     2 0 7 my $self = shift;
342 2         28 $self->SUPER::close_children(@_);
343              
344 2         24 check_sigs(); # since we have captured signals - make sure we handle them
345              
346 2         9 register_sig(PIPE => 'DEFAULT',
347             INT => 'DEFAULT',
348             TERM => 'DEFAULT',
349             QUIT => 'DEFAULT',
350             HUP => 'DEFAULT',
351             CHLD => 'DEFAULT',
352             TTIN => 'DEFAULT',
353             TTOU => 'DEFAULT',
354             );
355             }
356              
357             1;
358              
359             __END__