PREFORK_CHILDREN
-
gobiernan la política de planificación familiar
del servidor:
PREFORK_CHILDREN
hijos
@idle
desciende por debajo de LO_WATER_MARK
el padre creará LO_WATER_MARK-@idle
hijos
@idle
excede HI_WATER_MARK
el padre
eliminará @idle - HI_WATER_MARK
hijos
lhp@nereida:~/projects/perl/src/perl_networking/ch15$ cat -n prefork_pipe_server2.pl 1 #!/usr/bin/perl -w 2 use strict; 3 use IO::Socket; 4 use IO::File; 5 use IO::Select; 6 use IO::Pipe; 7 use Fcntl ':flock'; 8 use DaemonSimple; 9 use HTTPServer2; 10 11 use constant PREFORK_CHILDREN => 3; 12 use constant MAX_REQUEST => 30; 13 use constant PIDFILE => "/tmp/prefork.pid"; 14 use constant HI_WATER_MARK => 5; 15 use constant LO_WATER_MARK => 2; 16 use constant DEBUG => 1;
Después de servir MAX_REQUEST
peticiones un hijo termina.
De este modo podemos ver como el proceso de coordinación crea hijos para
sustituir a los que se marchan.
La variable $DONE
se va a usar para detectar la terminación.
Esta es activada por las señales INT
y TERM
.
18 my $DONE = 0; # set flag to true when server done 19 my %STATUS = (); 20 21 $SIG{INT} = $SIG{TERM} = sub { $DONE++ };Es el hash
STATUS
está indexado en los PIDs de los hijos y tiene por valor
el estado de actividad del hijo. Puede ser: idle
, busy
o done
.
Después de crear el socket de la forma habitual se procede
a crear un pipe para la comunicación entre los hijos y el padre.
Los hijos lo usaran para comunicar su estado con mensajes de la forma
PID status
:
22 my $port = shift || 8081; 23 my $socket = IO::Socket::INET->new( LocalPort => $port, 24 Listen => SOMAXCONN, 25 Reuse => 1 ) or die "Can't create listen socket: $!"; 26 27 # create a pipe for IPC 28 pipe(CHILD_READ,CHILD_WRITE) or die "Can't make pipe!\n"; 29 my $IN = IO::Select->new(\*CHILD_READ);
lhp@nereida:~/projects/perl/src/perl_networking/ch15$ cat -n prefork_pipe_server2.pl 1 #!/usr/bin/perl -w 2 use strict; 3 use IO::Socket; 4 use IO::File; 5 use IO::Select; 6 use Fcntl ':flock'; 7 use DaemonSimple; 8 use HTTPServer2; 9 10 use constant PREFORK_CHILDREN => 3; 11 use constant MAX_REQUEST => 30; 12 use constant PIDFILE => "/tmp/prefork.pid"; 13 use constant HI_WATER_MARK => 5; 14 use constant LO_WATER_MARK => 2; 15 use constant DEBUG => 1; 16 17 my $DONE = 0; # set flag to true when server done 18 my %STATUS = (); 19 20 $SIG{INT} = $SIG{TERM} = sub { $DONE++ }; 21 22 my $port = shift || 8081; 23 my $socket = IO::Socket::INET->new( LocalPort => $port, 24 Listen => SOMAXCONN, 25 Reuse => 1 ) or die "Can't create listen socket: $!"; 26 27 # create a pipe for IPC 28 pipe(CHILD_READ,CHILD_WRITE) or die "Can't make pipe!\n"; 29 my $IN = IO::Select->new(\*CHILD_READ); 30 31 # create PID file and go into background 32 init_server(PIDFILE); 33 34 # prefork some children 35 make_new_child() for (1..PREFORK_CHILDREN); 36 37 while (!$DONE) { 38 39 if ($IN->can_read) { # got a message from one of the children 40 my $message; 41 next unless sysread(CHILD_READ,$message,4096); 42 my @messages = split "\n",$message; 43 foreach (@messages) { 44 next unless my ($pid,$status) = /^(\d+) (.+)$/; 45 if ($status ne 'done') { 46 $STATUS{$pid} = $status; 47 } else { 48 delete $STATUS{$pid}; 49 } 50 } 51 } 52 53 # get the list of idle children 54 warn join(' ', map {"$_=>$STATUS{$_}"} keys %STATUS),"\n" if DEBUG; 55 my @idle = sort {$a <=> $b} grep {$STATUS{$_} eq 'idle'} keys %STATUS; 56 57 if (@idle < LO_WATER_MARK) { 58 make_new_child() for (0..LO_WATER_MARK-@idle-1); # bring the number up 59 } elsif (@idle > HI_WATER_MARK) { 60 my @goners = @idle[0..@idle - HI_WATER_MARK() - 1]; # kill the oldest ones 61 my $killed = kill HUP => @goners; 62 warn "killed $killed children\n" if DEBUG; 63 } 64 65 } 66 67 warn "Termination received, killing children\n" if DEBUG; 68 kill_children(); 69 warn "Normal termination.\n"; 70 exit 0; 71 72 sub make_new_child { 73 my $child = launch_child(\&cleanup_child); 74 if ($child) { # child > 0, so we're the parent 75 warn "launching child $child\n" if DEBUG; 76 $STATUS{$child} = 'idle'; 77 } else { 78 close CHILD_READ; # no need to read from pipe 79 do_child($socket); # child handles incoming connections 80 exit 0; # child is done 81 } 82 } 83 84 sub do_child { 85 my $socket = shift; 86 my $lock = IO::File->new(PIDFILE,O_RDONLY) or die "Can't open lock file: $!"; 87 my $cycles = MAX_REQUEST; 88 my $done = 0; 89 90 $SIG{HUP} = sub { $done++ }; 91 while ( !$done && $cycles-- ) { 92 syswrite CHILD_WRITE,"$$ idle\n"; 93 my $c; 94 next unless eval { 95 local $SIG{HUP} = sub { $done++; die }; 96 flock($lock,LOCK_EX); 97 warn "child $$: calling accept()\n" if DEBUG; 98 $c = $socket->accept; 99 flock($lock,LOCK_UN); 100 }; 101 syswrite CHILD_WRITE,"$$ busy\n"; 102 handle_connection($c); 103 close $c; 104 } 105 warn "child $$ done\n" if DEBUG; 106 syswrite CHILD_WRITE,"$$ done\n"; 107 close $_ foreach ($socket,$lock,\*CHILD_WRITE); 108 } 109 110 sub cleanup_child { 111 my $child = shift; 112 delete $STATUS{$child}; 113 }
lhp@nereida:~/projects/perl/src/perl_networking/ch15$ cat -n DaemonSimple.pm 1 package DaemonSimple; 2 use strict; 3 use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION); 4 5 use POSIX qw(:signal_h setsid WNOHANG); 6 use Carp 'croak','cluck'; 7 use File::Basename; 8 use IO::File; 9 require Exporter; 10 11 @EXPORT_OK = qw( init_server launch_child prepare_child); 12 @EXPORT = @EXPORT_OK; 13 @ISA = qw(Exporter); 14 $VERSION = '1.00'; 15 our %CHILDREN; 16 17 use constant PIDPATH => '/tmp'; 18 my ($pid,$pidfile); 19 20 sub init_server { 21 $pidfile = shift || getpidfilename(); 22 my $fh = open_pid_file($pidfile); 23 become_daemon(); 24 print $fh $$; 25 close $fh; 26 return $pid = $$; 27 } 28 29 sub become_daemon { 30 chdir '/'; # change working directory 31 umask(0); # forget file mode creation mask 32 $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin'; 33 $SIG{CHLD} = \&reap_child; 34 return $$; 35 } 36 37 sub getpidfilename { 38 my $basename = basename($0,'.pl'); 39 return PIDPATH . "/$basename.pid"; 40 } 41 42 sub open_pid_file { 43 my $file = shift; 44 if (-e $file) { # oops. pid file already exists 45 my $fh = IO::File->new($file) || return; 46 my $pid = <$fh>; 47 if ($pid && $pid =~ /^\d+$/) { 48 croak "Server already running with PID $pid" if kill 0 => $pid; 49 } 50 else { 51 $pid = "unknown"; 52 } 53 cluck "Removing PID file for defunct server process $pid.\n"; 54 croak"Can't unlink PID file $file" unless -w $file && unlink $file; 55 } 56 return IO::File->new($file,O_WRONLY|O_CREAT|O_EXCL,0644) 57 or die "Can't create $file: $!\n"; 58 } 59 60 sub reap_child { 61 do { } while waitpid(-1,WNOHANG) > 0; 62 } 63 64 sub launch_child { 65 my $callback = shift; 66 my $home = shift; 67 my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP); 68 sigprocmask(SIG_BLOCK,$signals); # block inconvenient signals 69 die("Can't fork: $!") unless defined (my $child = fork()); 70 if ($child) { 71 $CHILDREN{$child} = $callback || 1; 72 } else { 73 $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT'; 74 prepare_child($home); 75 } 76 sigprocmask(SIG_UNBLOCK,$signals); # unblock signals 77 return $child; 78 } 79 80 sub prepare_child { 81 my $home = shift; 82 if ($home) { 83 chdir $home || croak "chdir(): $!"; 84 } 85 } 86 87 88 sub kill_children { 89 my $n = kill TERM => keys %CHILDREN; 90 # wait until all the children die 91 wait for 1..$n 92 } 93 94 95 END { unlink $pidfile if defined $pid and $$ == $pid } 96 97 1;