El Programa Servidor con Logs

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
• La opción pid hace que se incluya el PID en cada mensaje
• La constante 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  }

El Módulo Dameon1.pm: Código Completo

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;

El Programa Principal

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 }
88

y 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.

El Código Completo

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  }

Ejecución

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