Сейчас знакомлюсь с книгой Вильямс - Разработка сетевых программ на Perl. Пытаюсь понять как это работает. Вообщем понимание есть но не совсем. Собственно проблема такая. Взял пример из книжки.. Даже если не переделывать то всё равно работает не правильно. Daemon.pm | Код |
package Daemon;
use strict;
use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION);
use POSIX qw(:signal_h setsid WNOHANG);
use Carp 'croak','cluck';
use Carp::Heavy;
use File::Basename;
use IO::File;
use Cwd;
use Sys::Syslog qw(:DEFAULT setlogsock);
#use LogFile;
require Exporter;
@EXPORT_OK = qw(init_server prepare_child kill_children
launch_child do_relaunch
log_debug log_notice log_warn
log_die %CHILDREN);
@EXPORT = @EXPORT_OK;
@ISA = qw(Exporter);
$VERSION = '1.00';
use constant PIDPATH => '/var/run';
use constant FACILITY => 'local0';
use vars qw(%CHILDREN);
my ($pid,$pidfile,$saved_dir,$CWD);
sub init_server {
my ($user,$group);
($pidfile,$user,$group) = @_;
$pidfile ||= getpidfilename();
my $fh = open_pid_file($pidfile);
become_daemon();
print $fh $$;
close $fh;
init_log();
change_privileges($user,$group) if defined $user && defined $group;
return $pid = $$;
}
sub become_daemon {
croak "Can't fork" unless defined (my $child = fork);
exit 0 if $child; # parent dies;
POSIX::setsid(); # become session leader
open(STDIN,"</dev/null");
open(STDOUT,">/dev/null");
open(STDERR,">&STDOUT");
$CWD = getcwd; # remember working directory
chdir '/'; # change working directory
umask(0); # forget file mode creation mask
$ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin';
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
$SIG{CHLD} = \&reap_child;
}
sub change_privileges {
my ($user,$group) = @_;
my $uid = getpwnam($user) or die "Can't get uid for $user\n";
my $gid = getgrnam($group) or die "Can't get gid for $group\n";
$) = "$gid $gid";
$( = $gid;
$> = $uid; # change the effective UID (but not the real UID)
}
sub launch_child {
my $callback = shift;
my $home = shift;
my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP);
sigprocmask(SIG_BLOCK,$signals); # block inconvenient signals
log_die("Can't fork: $!") unless defined (my $child = fork());
if ($child==0) {
$CHILDREN{$child} = $callback || 1;
} else {
$SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT';
prepare_child($home);
}
sigprocmask(SIG_UNBLOCK,$signals); # unblock signals
return $child;
}
sub prepare_child {
my $home = shift;
if ($home) {
local($>,$<) = ($<,$>); # become root again (briefly)
chdir $home || croak "chdir(): $!";
chroot $home || croak "chroot(): $!";
}
$< = $>; # set real UID to effective UID
}
sub reap_child {
while ( (my $child = waitpid(-1,WNOHANG)) > 0) {
$CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE';
delete $CHILDREN{$child};
}
}
sub kill_children {
kill TERM => keys %CHILDREN;
# wait until all the children die
sleep while %CHILDREN;
}
sub do_relaunch {
$> = $<; # regain privileges
chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!;
croak "bad program name" unless $0 =~ m!([./a-zA-z0-9_-]+)!;
my $program = $1;
my $port = $1 if $ARGV[0] =~ /(\d+)/;
unlink $pidfile;
exec 'perl','-T',$program,$port or croak "Couldn't exec: $!";
}
sub init_log {
setlogsock('unix');
my $basename = basename($0);
openlog($basename,'pid',FACILITY);
$SIG{__WARN__} = \&log_warn;
$SIG{__DIE__} = \&log_die;
}
sub log_debug { syslog('debug',_msg(@_)) }
sub log_notice { syslog('notice',_msg(@_)) }
sub log_warn { syslog('warning',_msg(@_)) }
sub log_die {
syslog('crit',_msg(@_)) unless $^S;
die @_;
}
sub _msg {
my $msg = join('',@_) || "Something's wrong";
my ($pack,$filename,$line) = caller(1);
$msg .= " at $filename line $line\n" unless $msg =~ /\n$/;
$msg;
}
sub getpidfilename {
my $basename = basename($0,'.pl');
return PIDPATH . "/$basename.pid";
}
sub open_pid_file {
my $file = shift;
if (-e $file) { # oops. pid file already exists
my $fh = IO::File->new($file) || return;
my $pid = <$fh>;
croak "Invalid PID file" unless $pid =~ /^(\d+)$/;
croak "Server already running with PID $1" if kill 0 => $1;
cluck "Removing PID file for defunct server process $pid.\n";
croak"Can't unlink PID file $file" unless -w $file && unlink $file;
}
return IO::File->new($file,O_WRONLY|O_CREAT|O_EXCL,0644)
or die "Can't create $file: $!\n";
}
END {
$> = $<; # regain privileges
unlink $pidfile if defined $pid and $$ == $pid
}
1;
__END__
|
Script.pl | Код |
#!/usr/bin/perl
# file: eliza_hup.pl
# Figure 14.6: Psychotherapist server that responds to HUP signal
use strict;
use lib '.';
use Chatbot::Eliza;
use IO::Socket;
use Daemon;
use constant PORT => 1002;
use constant PIDFILE => '/var/run/exchange.pid';
use constant USER => 'nobody';
use constant GROUP => 'nogroup';
use constant EXCHANGE => '/home/o6s/scripts/perl/daemon';
#init_log('/home/o6s/scripts/daemon/log.log') or die "can't open logfile\n";
# signal handler for child die events
$SIG{TERM} = $SIG{INT} = \&do_term;
$SIG{HUP} = \&do_hup;
my $port = $ARGV[0] || PORT;
my $listen_socket = IO::Socket::INET->new(LocalPort => $port,
Listen => 20,
Proto => 'tcp',
Reuse => 1);
die "Can't create a listening socket: $@" unless $listen_socket;
my $pid = init_server(PIDFILE,USER,GROUP,$port);
log_notice "Server accepting connections on port $port\n";
while (my $connection = $listen_socket->accept) {
my $host = $connection->peerhost;
my $child = launch_child(undef,EXCHANGE);
if ($child == 0) {
$listen_socket->close;
log_notice("Accepting a connection from $host\n");
interact($connection);
log_notice("Connection from $host finished\n");
exit 0;
}
$connection->close;
}
sub interact {
my $sock = shift;
STDIN->fdopen($sock,"r") or die "Can't reopen STDIN: $!";
STDOUT->fdopen($sock,"w") or die "Can't reopen STDOUT: $!";
STDERR->fdopen($sock,"w") or die "Can't reopen STDERR: $!";
$| = 1;
che-nit' delaem );
}
sub do_term {
log_notice("TERM signal received, terminating children...\n");
kill_children();
exit 0;
}
sub do_hup {
log_notice("HUP signal received, reinitializing...\n");
log_notice("Closing listen socket...\n");
close $listen_socket;
log_notice("Terminating children...\n");
kill_children;
log_notice("Trying to relaunch...\n");
do_relaunch();
log_die("Relaunch failed. Died");
}
END {
log_notice("Server exiting normally\n") if $$ == $pid;
}
|
посмотрел на дебаг.. подумал.. нчего ценного в голову не приходит... Вообщем в кратце. my $pid = init_server(PIDFILE,USER,GROUP,$port); выполняется отлично т.е. закрывется родительский процесс и порождается fork. while (my $connection = $listen_socket->accept) { начинаем слушать соединение, тоже отлично работает. my $child = launch_child(undef,EXCHANGE); рождается новый процесс который должен обработать tcp запрос и умереть. И всё вроде ок, после второго процесса помирает основной процесс.. Лог выглядит так | Код |
Jun 8 22:53:09 script.pl[6858]: Server accepting connections on port 1002
Jun 8 22:53:24 script.pl[6917]: Accepting a connection from 127.0.0.1
Jun 8 22:56:00 script.pl[6917]: Connection from 127.0.0.1 finished
Jun 8 22:56:18 script.pl[6858]: chdir(): No such file or directory script.pl line 33
Jun 8 22:56:18 script.pl[7569]: Accepting a connection from 127.0.0.1
Jun 8 22:56:18 script.pl[6858]: Server exiting normally
|
ну и соответственно конец ) Уже сломал весть мозг, но так и не могу понять почему во второй раз не отрабатывает chdir.. Заранее спасибо. |
fork daemon 
Загрузка ...
