Los cambios principales son los siguientes:
launch_child
)
y de manejo de la señal de CHLD
para llevar en las claves del hash %CHILDREN
los PIDs y en los valores
los callbacks. Esto es manejado por la función reap_child
:
90 sub reap_child { 91 while ( (my $child = waitpid(-1,WNOHANG)) > 0) { 92 $CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE'; 93 delete $CHILDREN{$child}; 94 } 95 }
kill_children
que termina todas las conexiones activas
97 sub kill_children { 98 kill TERM => keys %CHILDREN; 99 # wait until all the children die 100 sleep while %CHILDREN; 101 }
do_realunch
que relanza el servidor después de la recepción de una señal
HUP
:
103 sub do_relaunch { 104 $> = $<; # regain privileges 105 chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!; 106 croak "bad program name" unless $0 =~ m!([./a-zA-z0-9_-]+)!; 107 my $program = $1; 108 my $port = $1 if $ARGV[0] =~ /(\d+)/; 109 unlink $pidfile; 110 exec 'perl','-T',$program,$port or croak "Couldn't exec: $!"; 111 }
Los procesos hijo por defecto heredan los manejadores de señales establecidos por el proceso
padre. En consecuencia heredan el manejador de HUP
el cual rearranca el servidor.
No queremos que cada hijo ejecute este manejadorpues ello daría lugar a múltiples intentos opr los hijos de
relanzar el servidor.
Para ello bastaría con establecer el manejador de señal de HUP
para el hijo
a DEFAULT
. Existe no obstante el riesgo de que una señal de HUP
llegue en el periodo que va desde la creación del hijo hasta la asignación
73 $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT';
Para ello se deben bloquear las señales antes de hacer el forking para desbloquearlas después tanto en el padre como en el hijo:
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 log_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 }
La función sigprocmask del módulo POSIX lo hace posible. Se llama de la forma:
$result = sigprocmask($operation, $newsigset, [$oldsigset])
sigprocmask
permite la manipulación de la máscara de señales del proceso:
una máscatra de bits que controla que señales serán o no recibidas.
Por defecto un proceso recibe todas las señales del sistema oeprativo
pero podemos bloquear algunas modificando la máscara.
Las señales no se descartan sino que se guardan
esperando hasta el momento en el
que el proceso desbloquee la señal.
Las operaciones pueden ser:
SIG_BLOCK
Las señales indicadas se añaden a la máscara para bloqueo
SIG_UNBLOCK
Las señales indicadas se retiran de la máscara, desbloqueando las señales
SIG_SETMASK
La máscara de señales es borrada y reemplazada por el conjunto
de señales inicado en $newsigset
sigprocmask
retorna verdadero si tuvo éxito.
Las señales pueden ser creadas y examinadas utilizando la clase POSIX::SigSet .
El módulo importa las funciones POSIX
correspondientes a la etiqueta :signal_h
.
1 package Daemon; 2 use strict; 3 our (@EXPORT, @ISA, @EXPORT_OK, $VERSION); 4 5 use POSIX qw(:signal_h setsid WNOHANG); 6 use Carp 'croak','cluck'; 7 use Carp::Heavy; 8 use File::Basename; 9 use IO::File; 10 use Cwd; 11 use Sys::Syslog qw(:DEFAULT setlogsock); 12 require Exporter; 13 14 @EXPORT_OK = qw(init_server prepare_child kill_children 15 launch_child do_relaunch 16 log_debug log_notice log_warn 17 log_die %CHILDREN); 18 @EXPORT = @EXPORT_OK; 19 @ISA = qw(Exporter); 20 $VERSION = '1.00';
En la función become_daemon
recordamos en la variable
$CWD
el directorio de arranque.
El resto de la rutina no tiene
cambios sustanciales:
40 sub become_daemon { 41 croak "Can't fork" unless defined (my $child = fork); 42 exit 0 if $child; # parent dies; 43 POSIX::setsid(); # become session leader 44 open(STDIN,"</dev/null"); 45 open(STDOUT,">/dev/null"); 46 open(STDERR,">&STDOUT"); 47 $CWD = getcwd; # remember working directory 48 chdir '/'; # change working directory 49 umask(0); # forget file mode creation mask 50 $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin'; 51 delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'}; 52 $SIG{CHLD} = \&reap_child; 53 }La variable
$CWD
será utilizada durante
el rearranque del servidor.
103 sub do_relaunch { 104 $> = $<; # regain privileges 105 chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!; 106 croak "bad program name" unless $0 =~ m!([./a-zA-z0-9_-]+)!; 107 my $program = $1; 108 my $port = $1 if $ARGV[0] =~ /(\d+)/; 109 unlink $pidfile; 110 exec 'perl','-T',$program,$port or croak "Couldn't exec: $!"; 111 }
root@beowulf:/home/casiano/src/perl/serverwithhup# cat -n Daemon.pm 1 package Daemon; 2 use strict; 3 our (@EXPORT, @ISA, @EXPORT_OK, $VERSION); 4 5 use POSIX qw(:signal_h setsid WNOHANG); 6 use Carp 'croak','cluck'; 7 use Carp::Heavy; 8 use File::Basename; 9 use IO::File; 10 use Cwd; 11 use Sys::Syslog qw(:DEFAULT setlogsock); 12 require Exporter; 13 14 @EXPORT_OK = qw(init_server prepare_child kill_children 15 launch_child do_relaunch 16 log_debug log_notice log_warn 17 log_die %CHILDREN); 18 @EXPORT = @EXPORT_OK; 19 @ISA = qw(Exporter); 20 $VERSION = '1.00'; 21 22 use constant PIDPATH => '/var/run'; 23 use constant FACILITY => 'local0'; 24 our %CHILDREN; 25 my ($pid,$pidfile,$saved_dir,$CWD); 26 27 sub init_server { 28 my ($user,$group); 29 ($pidfile,$user,$group) = @_; 30 $pidfile ||= getpidfilename(); 31 my $fh = open_pid_file($pidfile); 32 become_daemon(); 33 print $fh $$; 34 close $fh; 35 init_log(); 36 change_privileges($user,$group) if defined $user && defined $group; 37 return $pid = $$; 38 } 39 40 sub become_daemon { 41 croak "Can't fork" unless defined (my $child = fork); 42 exit 0 if $child; # parent dies; 43 POSIX::setsid(); # become session leader 44 open(STDIN,"</dev/null"); 45 open(STDOUT,">/dev/null"); 46 open(STDERR,">&STDOUT"); 47 $CWD = getcwd; # remember working directory 48 chdir '/'; # change working directory 49 umask(0); # forget file mode creation mask 50 $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin'; 51 delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'}; 52 $SIG{CHLD} = \&reap_child; 53 } 54 55 sub change_privileges { 56 my ($user,$group) = @_; 57 my $uid = getpwnam($user) or die "Can't get uid for $user\n"; 58 my $gid = getgrnam($group) or die "Can't get gid for $group\n"; 59 $) = "$gid $gid"; 60 $( = $gid; 61 $> = $uid; # change the effective UID (but not the real UID) 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 log_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 local($>,$<) = ($<,$>); # become root again (briefly) 84 chdir $home || croak "chdir(): $!"; 85 chroot $home || croak "chroot(): $!"; 86 } 87 $< = $>; # set real UID to effective UID 88 } 89 90 sub reap_child { 91 while ( (my $child = waitpid(-1,WNOHANG)) > 0) { 92 $CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE'; 93 delete $CHILDREN{$child}; 94 } 95 } 96 97 sub kill_children { 98 kill TERM => keys %CHILDREN; 99 # wait until all the children die 100 sleep while %CHILDREN; 101 } 102 103 sub do_relaunch { 104 $> = $<; # regain privileges 105 chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!; 106 croak "bad program name" unless $0 =~ m!([./a-zA-z0-9_-]+)!; 107 my $program = $1; 108 my $port = $1 if $ARGV[0] =~ /(\d+)/; 109 unlink $pidfile; 110 exec 'perl','-T',$program,$port or croak "Couldn't exec: $!"; 111 } 112 113 sub init_log { 114 setlogsock('unix'); 115 my $basename = basename($0); 116 openlog($basename,'pid',FACILITY); 117 $SIG{__WARN__} = \&log_warn; 118 $SIG{__DIE__} = \&log_die; 119 } 120 121 sub log_debug { syslog('debug',_msg(@_)) } 122 sub log_notice { syslog('notice',_msg(@_)) } 123 sub log_warn { syslog('warning',_msg(@_)) } 124 sub log_die { 125 syslog('crit',_msg(@_)) unless $^S; 126 die @_; 127 } 128 sub _msg { 129 my $msg = join('',@_) || "Something's wrong"; 130 my ($pack,$filename,$line) = caller(1); 131 $msg .= " at $filename line $line\n" unless $msg =~ /\n$/; 132 $msg; 133 } 134 135 sub getpidfilename { 136 my $basename = basename($0,'.pl'); 137 return PIDPATH . "/$basename.pid"; 138 } 139 140 sub open_pid_file { 141 my $file = shift; 142 if (-e $file) { # oops. pid file already exists 143 my $fh = IO::File->new($file) || return; 144 my $pid = <$fh>; 145 croak "Invalid PID file" unless $pid =~ /^(\d+)$/; 146 croak "Server already running with PID $1" if kill 0 => $1; 147 cluck "Removing PID file for defunct server process $pid.\n"; 148 croak"Can't unlink PID file $file" unless -w $file && unlink $file; 149 } 150 return IO::File->new($file,O_WRONLY|O_CREAT|O_EXCL,0644) 151 or die "Can't create $file: $!\n"; 152 } 153 154 END { 155 $> = $<; # regain privileges 156 unlink $pidfile if defined $pid and $$ == $pid 157 } 158 159 1; 160 __END__
root@beowulf:/home/casiano/src/perl/serverwithhup# ps -fA | grep eliza nobody 1404 1 0 18:54 ? 00:00:00 /usr/bin/perl -w -T ./eliza_hup.pl root 1406 16664 0 18:54 pts/0 00:00:00 grep eliza root@beowulf:/home/casiano/src/perl/serverwithhup# telnet localhost 1200 Trying 127.0.0.1... Connected to localhost.localdomain. Escape character is '^]'. Eliza: Please tell me what's been bothering you. you: bye Eliza: I think you should talk to a REAL analyst. Ciao! Connection closed by foreign host.