File Coverage

blib/lib/Net/Server/Fork.pm
Criterion Covered Total %
statement 66 127 51.9
branch 12 46 26.0
condition 1 2 50.0
subroutine 13 20 65.0
pod 4 8 50.0
total 96 203 47.2


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::Fork - 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::Fork;
19              
20 2     2   9374 use strict;
  2         4  
  2         64  
21 2     2   12 use base qw(Net::Server);
  2         2  
  2         774  
22 2     2   742 use Net::Server::SIG qw(register_sig check_sigs);
  2         4  
  2         114  
23 2     2   10 use Socket qw(SO_TYPE SOL_SOCKET SOCK_DGRAM);
  2         4  
  2         114  
24 2     2   10 use POSIX qw(WNOHANG);
  2         4  
  2         10  
25              
26 1     1 0 3 sub net_server_type { __PACKAGE__ }
27              
28             sub options {
29 1     1 0 2 my $self = shift;
30 1         8 my $ref = $self->SUPER::options(@_);
31 1         4 my $prop = $self->{'server'};
32 1         12 $ref->{$_} = \$prop->{$_} for qw(max_servers max_dequeue check_for_dead check_for_dequeue);
33 1         14 $ref->{'sig_passthrough'} = $prop->{'sig_passthrough'} = [];
34 1         6 return $ref;
35             }
36              
37             sub post_configure {
38 1     1 1 2 my $self = shift;
39 1         2 my $prop = $self->{'server'};
40 1         8 $self->SUPER::post_configure(@_);
41              
42 1 50       5 $prop->{'max_servers'} = 256 if ! defined $prop->{'max_servers'};
43 1 50       4 $prop->{'check_for_dead'} = 60 if ! defined $prop->{'check_for_dead'};
44              
45 1         11 $prop->{'ppid'} = $$;
46 1         5 $prop->{'multi_port'} = 1;
47             }
48              
49             sub loop {
50 1     1 1 4 my $self = shift;
51 1         1 my $prop = $self->{'server'};
52              
53 1         6 $prop->{'children'} = {};
54 1 50       4 if ($ENV{'HUP_CHILDREN'}) {
55 0         0 my %children = map {/^(\w+)$/; $1} split(/\s+/, $ENV{'HUP_CHILDREN'});
  0         0  
  0         0  
56 0         0 $children{$_} = {status => $children{$_}, hup => 1} foreach keys %children;
57 0         0 $prop->{'children'} = \%children;
58             }
59              
60             # register some of the signals for safe handling
61             register_sig(
62             PIPE => 'IGNORE',
63 1     1   25 INT => sub { $self->server_close() },
64 0     0   0 TERM => sub { $self->server_close() },
65 0     0   0 HUP => sub { $self->sig_hup() },
66             CHLD => sub {
67 0     0   0 while (defined(my $chld = waitpid(-1, WNOHANG))) {
68 0 0       0 last if $chld <= 0;
69 0         0 $self->delete_child($chld);
70             }
71             },
72 0     0   0 QUIT => sub { $self->{'server'}->{'kind_quit'} = 1; $self->server_close() },
  0         0  
73 0     0   0 TTIN => sub { $self->{'server'}->{'max_servers'}++; $self->log(3, "Increasing max server count ($self->{'server'}->{'max_servers'})") },
  0         0  
74 0     0   0 TTOU => sub { $self->{'server'}->{'max_servers'}--; $self->log(3, "Decreasing max server count ($self->{'server'}->{'max_servers'})") },
  0         0  
75 1         25 );
76              
77 1         15 $self->register_sig_pass;
78              
79 1 50       3 if ($ENV{'HUP_CHILDREN'}) {
80 0         0 while (defined(my $chld = waitpid(-1, WNOHANG))) {
81 0 0       0 last unless $chld > 0;
82 0         0 $self->delete_child($chld);
83             }
84             }
85              
86 1         3 my ($last_checked_for_dead, $last_checked_for_dequeue) = (time(), time());
87              
88 1         2 while (1) {
89              
90             ### make sure we don't use too many processes
91 2         12 my $n_children = grep { $_->{'status'} !~ /dequeue/ } values %{ $prop->{'children'} };
  1         12  
  2         19  
92 2         6 while ($n_children > $prop->{'max_servers'}){
93              
94 0         0 select(undef, undef, undef, 5); # block for a moment (don't look too often)
95 0         0 check_sigs();
96              
97 0         0 my $time = time();
98 0 0       0 if ($time - $last_checked_for_dead > $prop->{'check_for_dead'}) {
99 0         0 $last_checked_for_dead = $time;
100 0         0 $self->log(2, "Max number of children reached ($prop->{max_servers}) -- checking for alive.");
101 0         0 foreach (keys %{ $prop->{'children'} }){
  0         0  
102 0 0       0 kill(0,$_) or $self->delete_child($_);
103             }
104             }
105 0         0 $n_children = grep { $_->{'status'} !~ /dequeue/ } values %{ $prop->{'children'} };
  0         0  
  0         0  
106             }
107              
108 2 50       5 if ($prop->{'check_for_dequeue'}) {
109 0         0 my $time = time();
110 0 0       0 if ($time - $last_checked_for_dequeue > $prop->{'check_for_dequeue'}) {
111 0         0 $last_checked_for_dequeue = $time;
112 0 0       0 if ($prop->{'max_dequeue'}) {
113 0         0 my $n_dequeue = grep { $_->{'status'} =~ /dequeue/ } values %{ $prop->{'children'} };
  0         0  
  0         0  
114 0 0       0 $self->run_dequeue() if $n_dequeue < $prop->{'max_dequeue'};
115             }
116             }
117             }
118              
119 2         13 $self->pre_accept_hook;
120              
121 2 50       26 if (! $self->accept()) {
122 0 0       0 last if $prop->{'_HUP'};
123 0 0       0 last if $prop->{'done'};
124 0         0 next;
125             }
126              
127 1         16 $self->pre_fork_hook;
128              
129             ### fork a child so the parent can go back to listening
130 1         18 local $!;
131 1         594 my $pid = fork;
132 1 50       28 if (! defined $pid) {
133 0         0 $self->log(1, "Bad fork [$!]");
134 0         0 sleep 5;
135 0         0 next;
136             }
137              
138             # child
139 1 50       142 if (! $pid) {
140 0         0 $self->run_client_connection;
141 0         0 exit;
142             }
143              
144             # parent
145 1 50       26 close($prop->{'client'}) if !$prop->{'udp_true'};
146 1         36 $prop->{'children'}->{$pid}->{'status'} = 'processing';
147             }
148             }
149              
150       2 1   sub pre_accept_hook {};
151              
152             sub accept {
153 2     2 0 124 my ($self, $class) = @_;
154 2         7 my $prop = $self->{'server'};
155              
156             # block on trying to get a handle (select created because we specified multi_port)
157 2         23 my @socks = $prop->{'select'}->can_read(2);
158 2 50       591 if (check_sigs()) {
159 0 0       0 return undef if $prop->{'_HUP'};
160 0 0       0 return undef if ! @socks; # don't continue unless we have a connection
161             }
162              
163 1         46 my $sock = $socks[rand @socks];
164 1 50       6 return undef if ! defined $sock;
165              
166             # check if this is UDP
167 1 50       11 if (SOCK_DGRAM == $sock->getsockopt(SOL_SOCKET,SO_TYPE)) {
168 0         0 $prop->{'udp_true'} = 1;
169 0         0 $prop->{'client'} = $sock;
170 0         0 $prop->{'udp_peer'} = $sock->recv($prop->{'udp_data'}, $sock->NS_recv_len, $sock->NS_recv_flags);
171              
172             # Receive a SOCK_STREAM (TCP or UNIX) packet
173             } else {
174 1         65 delete $prop->{'udp_true'};
175 1   50     6 $prop->{'client'} = $sock->accept($class) || return;
176             }
177             }
178              
179             sub run_client_connection {
180 0     0 1 0 my $self = shift;
181              
182             ### close the main sock, we still have
183             ### the client handle, this will allow us
184             ### to HUP the parent at any time
185 0         0 $_ = undef foreach @{ $self->{'server'}->{'sock'} };
  0         0  
186              
187             ### restore sigs (for the child)
188 0         0 $SIG{'HUP'} = $SIG{'CHLD'} = $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = 'DEFAULT';
189 0         0 $SIG{'PIPE'} = 'IGNORE';
190              
191 0         0 delete $self->{'server'}->{'children'};
192              
193 0         0 $self->child_init_hook;
194              
195 0         0 $self->SUPER::run_client_connection;
196              
197 0         0 $self->child_finish_hook;
198             }
199              
200             sub close_children {
201 1     1 0 7 my $self = shift;
202 1         13 $self->SUPER::close_children(@_);
203              
204 1         9 check_sigs(); # since we have captured signals - make sure we handle them
205              
206 1         4 register_sig(PIPE => 'DEFAULT',
207             INT => 'DEFAULT',
208             TERM => 'DEFAULT',
209             QUIT => 'DEFAULT',
210             HUP => 'DEFAULT',
211             CHLD => 'DEFAULT',
212             TTIN => 'DEFAULT',
213             TTOU => 'DEFAULT',
214             );
215             }
216              
217             1;
218              
219             __END__