El programa comienza a crecer en exceso por lo que es conveniente
poner en un módulo aparte las funciones de apoyo:
become_daemon
,
open_pid_file
, etc.
Incluiremos también en este módulo
algunas funciones de soporte al
sistema de log.
Crearemos además una función init_server
que envuelve
las tareas de crear el fichero de PID, poner el proceso en background y
apertura del sistema de log:
sub init_server { $pidfile = shift || getpidfilename(); my $fh = open_pid_file($pidfile); become_daemon(); print $fh $$; close $fh; init_log(); return $pid = $$; }
Es nueva la llamada a init_log
que inicializa el sistema de log.
Esta subrutina establece el modo de conexión a UNIX
mediante la llamada a setlogsock
.
45 sub init_log { 46 setlogsock('unix'); 47 my $basename = basename($0); 48 openlog($basename,'pid',FACILITY); 49 }
En este caso los tres argumentos de openlog son:
$identity
es el nombre del programa que ha sido obtenido llamando a basename
pid
hace que se incluya el PID en cada mensaje
FACILITY
ha sido puesta a local0
La subrutina become_daemon
es parecida a la versión anterior:
Pone el servicio en background a cargo del hijo, se desliga de la terminal
y de la entrada/salida/error estandar.
31 sub become_daemon { 32 die "Can't fork" unless defined (my $child = fork); 33 exit 0 if $child; # parent dies; 34 setsid(); # become session leader 35 open(STDIN, "</dev/null"); 36 open(STDOUT,">/dev/null"); 37 open(STDERR,">&STDOUT"); 38 chdir '/'; # change working directory 39 umask(0); # forget file mode creation mask 40 $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin'; 41 $SIG{CHLD} = \&reap_child; 42 return $$; 43 }La principal novedad está en la presencia del manejador para la señal CHLD (17):
83 sub reap_child { 84 do { } while waitpid(-1,WNOHANG) > 0; 85 }
Las subrutinas log_*
proveen una interfaz cómoda
al sistema de syslog. Las subrutinas log_warn
y log_die
imitan el estilo de warn
y die
.
51 sub log_debug { syslog('debug',_msg(@_)) } 52 sub log_notice { syslog('notice',_msg(@_)) } 53 sub log_warn { syslog('warning',_msg(@_)) } 54 sub log_die { 55 syslog('crit',_msg(@_)); 56 die @_; 57 } 58 sub _msg { 59 my $msg = join('',@_) || "Something's wrong"; 60 my ($pack,$filename,$line) = caller(1); 61 $msg .= " at $filename line $line\n" unless $msg =~ /\n$/; 62 $msg; 63 }
casiano@beowulf:~/src/perl/syslog$ cat -n Daemon1.pm 1 package Daemon1; 2 use strict; 3 use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION); 4 5 use POSIX qw(setsid WNOHANG); 6 use Carp 'croak','cluck'; 7 use File::Basename; 8 use IO::File; 9 use Sys::Syslog qw(:DEFAULT setlogsock); 10 require Exporter; 11 12 @EXPORT_OK = qw( init_server log_debug log_notice log_warn log_die); 13 @EXPORT = @EXPORT_OK; 14 @ISA = qw(Exporter); 15 $VERSION = '1.00'; 16 17 use constant PIDPATH => '/tmp'; 18 use constant FACILITY => 'local0'; 19 my ($pid,$pidfile); 20 21 sub init_server { 22 $pidfile = shift || getpidfilename(); 23 my $fh = open_pid_file($pidfile); 24 become_daemon(); 25 print $fh $$; 26 close $fh; 27 init_log(); 28 return $pid = $$; 29 } 30 31 sub become_daemon { 32 die "Can't fork" unless defined (my $child = fork); 33 exit 0 if $child; # parent dies; 34 setsid(); # become session leader 35 open(STDIN, "</dev/null"); 36 open(STDOUT,">/dev/null"); 37 open(STDERR,">&STDOUT"); 38 chdir '/'; # change working directory 39 umask(0); # forget file mode creation mask 40 $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin'; 41 $SIG{CHLD} = \&reap_child; 42 return $$; 43 } 44 45 sub init_log { 46 setlogsock('unix'); 47 my $basename = basename($0); 48 openlog($basename,'pid',FACILITY); 49 } 50 51 sub log_debug { syslog('debug',_msg(@_)) } 52 sub log_notice { syslog('notice',_msg(@_)) } 53 sub log_warn { syslog('warning',_msg(@_)) } 54 sub log_die { 55 syslog('crit',_msg(@_)); 56 die @_; 57 } 58 sub _msg { 59 my $msg = join('',@_) || "Something's wrong"; 60 my ($pack,$filename,$line) = caller(1); 61 $msg .= " at $filename line $line\n" unless $msg =~ /\n$/; 62 $msg; 63 } 64 65 sub getpidfilename { 66 my $basename = basename($0,'.pl'); 67 return PIDPATH . "/$basename.pid"; 68 } 69 70 sub open_pid_file { 71 my $file = shift; 72 if (-e $file) { # oops. pid file already exists 73 my $fh = IO::File->new($file) || return; 74 my $pid = <$fh>; 75 croak "Server already running with PID $pid" if kill 0 => $pid; 76 cluck "Removing PID file for defunct server process $pid.\n"; 77 croak"Can't unlink PID file $file" unless -w $file && unlink $file; 78 } 79 return IO::File->new($file,O_WRONLY|O_CREAT|O_EXCL,0644) 80 or die "Can't create $file: $!\n"; 81 } 82 83 sub reap_child { 84 do { } while waitpid(-1,WNOHANG) > 0; 85 } 86 87 END { unlink $pidfile if defined $pid and $$ == $pid } 88 89 1;
Los manejadores de las señales TERM
e INT
hacen que se ejecute
un exit
.
casiano@beowulf:~/src/perl/syslog$ cat -n eliza_log.pl 1 #!/usr/bin/perl 2 use strict; 3 use Chatbot::Eliza; 4 use IO::Socket; 5 use Daemon1; 6 7 use constant PORT => 12000; 8 9 # signal handler for child die events 10 $SIG{TERM} = $SIG{INT} = sub { exit 0; };De este modo se garantiza que los bloques
END{}
se ejecutarán
dándole la oportunidad al servidor de borrar el fichero de PID.
Hay dos bloques END{}
, uno en el módulo:
86 87 END { unlink $pidfile if defined $pid and $$ == $pid } 88y otro en el programa:
51 END { 52 log_notice("Server exiting normally\n") if $$ == $pid; 53 }
No se instala un manejador de CHLD
pues se ha hecho en become_daemon
.
Después de la llamada a init_server
estamos en background y no podemos escribir
a STDERR
.
12 my $port = shift || PORT; 13 my $listen_socket = IO::Socket::INET->new(LocalPort => $port, 14 Listen => 20, 15 Proto => 'tcp', 16 Reuse => 1); 17 die "Can't create a listening socket: $@" unless $listen_socket; 18 my $pid = init_server();
Entramos después en el bucle de aceptación. Para cada conexión entrante creamos
un proceso hijo que le dará servicio. Ahora podemos enviar información de nuestro proceso
al sistema de log mediante log_notice
y log_die
. Mediante
el método peerhost podemos obtener el nombre/IP del nodo remoto.
20 log_notice "Server accepting connections on port $port\n"; 21 22 while (my $connection = $listen_socket->accept) { 23 log_die("Can't fork: $!") unless defined (my $child = fork()); 24 if ($child == 0) { 25 $listen_socket->close; 26 my $host = $connection->peerhost; 27 log_notice("Accepting a connection from $host\n"); 28 interact($connection); 29 log_notice("Connection from $host finished\n"); 30 exit 0; 31 } 32 $connection->close; 33 }
El proceso hijo no debe llamar a accept de nuevo - usaremos el socket
conectado $connection
- y por ello ciera la copia del
socket de escucha $listen_socket->close
.
Este cierre no es estrictamente necesario pero es una buena costumbre:
libera recursos y evita un acceso accidental al socket.
Ahora podemos llamar a la rutina interact
a la que se le pasa el socket conectado.
Este es el método que maneja el programa que da el servicio.
Cuando termina el proceso hijo abandona con exit
.
El bloque END{}
es invocado únicamente por el proceso
principal.
86 87 END { unlink $pidfile if defined $pid and $$ == $pid } 88
No borramos aqui el fichero PID pues lo hicimos en el bloque END
en
el módulo.
casiano@beowulf:~/src/perl/syslog$ cat -n eliza_log.pl 1 #!/usr/bin/perl 2 use strict; 3 use Chatbot::Eliza; 4 use IO::Socket; 5 use Daemon1; 6 7 use constant PORT => 12000; 8 9 # signal handler for child die events 10 $SIG{TERM} = $SIG{INT} = sub { exit 0; }; 11 12 my $port = shift || PORT; 13 my $listen_socket = IO::Socket::INET->new(LocalPort => $port, 14 Listen => 20, 15 Proto => 'tcp', 16 Reuse => 1); 17 die "Can't create a listening socket: $@" unless $listen_socket; 18 my $pid = init_server(); 19 20 log_notice "Server accepting connections on port $port\n"; 21 22 while (my $connection = $listen_socket->accept) { 23 log_die("Can't fork: $!") unless defined (my $child = fork()); 24 if ($child == 0) { 25 $listen_socket->close; 26 my $host = $connection->peerhost; 27 log_notice("Accepting a connection from $host\n"); 28 interact($connection); 29 log_notice("Connection from $host finished\n"); 30 exit 0; 31 } 32 $connection->close; 33 } 34 35 sub interact { 36 my $sock = shift; 37 STDIN->fdopen($sock,"r") or die "Can't reopen STDIN: $!"; 38 STDOUT->fdopen($sock,"w") or die "Can't reopen STDOUT: $!"; 39 STDERR->fdopen($sock,"w") or die "Can't reopen STDERR: $!"; 40 $| = 1; 41 my $bot = Chatbot::Eliza->new; 42 $bot->command_interface; 43 } 44 45 sub Chatbot::Eliza::_testquit { 46 my ($self,$string) = @_; 47 return 1 unless defined $string; # test for EOF 48 foreach (@{$self->{quit}}) { return 1 if $string =~ /\b$_\b/i }; 49 } 50 51 END { 52 log_notice("Server exiting normally\n") if $$ == $pid; 53 }
La ejecución del servidor
y las posteriores conexiones darán lugar a entradas en el fichero /var/log/syslog
similares a estas:
casiano@beowulf:~/src/perl/syslog$ telnet localhost 12000 Trying 127.0.0.1... Connected to localhost.localdomain. Escape character is '^]'. Eliza: Is something troubling you? you: bye Eliza: I think you should talk to a REAL analyst. Ciao! Connection closed by foreign host. |
root@beowulf:/home/casiano/src/perl/syslog# grep -i eliza /var/log/syslog May 21 17:19:39 beowulf eliza_log.pl[32342]: Server accepting connections on port 12000 May 21 17:19:42 beowulf eliza_log.pl[32344]: Accepting a connection from 127.0.0.1 May 21 17:19:44 beowulf eliza_log.pl[32344]: Connection from finished 127.0.0.1 May 21 17:19:44 beowulf eliza_log.pl[32342]: Server exiting normally |