DaemonDebug (Chapter 14) The DaemonDebug module exports the same functions as the Daemon module described in Chapter 14. However, it remains in the foreground and leaves standard error open. This makes it easier to debug with during development. 0 package DaemonDebug; 1 use strict; 2 use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION); 3 use POSIX qw(:signal_h WNOHANG); 4 use Carp 'croak','cluck'; 5 use File::Basename; 6 use IO::File; 7 require Exporter; 8 @EXPORT_OK = qw(init_server prepare_child kill_children 9 launch_child do_relaunch 10 log_debug log_notice log_warn 11 log_die %CHILDREN); 12 @EXPORT = @EXPORT_OK; 13 @ISA = qw(Exporter); 14 $VERSION = '1.00'; 15 use constant PIDPATH => '/tmp'; 16 use vars '%CHILDREN'; 17 my ($pid,$pidfile,$saved_dir,$CWD); 18 sub init_server { 19 $pidfile = shift; 20 $pidfile = getpidfilename(); 21 my $fh = open_pid_file($pidfile); 22 print $fh $$; 23 close $fh; 24 $SIG{CHLD} = \&reap_child; 25 return $pid = $$; 26 } 27 sub launch_child { 28 my $callback = shift; 29 my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP); 30 sigprocmask(SIG_BLOCK,$signals); # block inconvenient signals 31 log_die("Can't fork: $!") unless defined (my $child = fork()); 32 if ($child) { 33 $CHILDREN{$child} = $callback 1; 34 } else { 35 $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT'; 36 } 37 sigprocmask(SIG_UNBLOCK,$signals); # unblock signals 38 return $child; 39 } 40 sub reap_child { 41 while ( (my $child = waitpid(-1,WNOHANG)) > 0) { 42 $CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE'; 43 delete $CHILDREN{$child}; 44 } 45 } 46 sub kill_children { 47 kill TERM => $_ foreach keys %CHILDREN; 48 # wait until all the children die 49 sleep while %CHILDREN; 50 } 51 sub do_relaunch { } # no-op 52 sub log_debug { &warn } 53 sub log_notice { &warn } 54 sub log_warn { &warn } 55 sub log_die { &die } 56 sub getpidfilename { 57 my $basename = basename( 0 package DaemonDebug; 1 use strict; 2 use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION); 3 use POSIX qw(:signal_h WNOHANG); 4 use Carp 'croak','cluck'; 5 use File::Basename; 6 use IO::File; 7 require Exporter; 8 @EXPORT_OK = qw(init_server prepare_child kill_children 9 launch_child do_relaunch 10 log_debug log_notice log_warn 11 log_die %CHILDREN); 12 @EXPORT = @EXPORT_OK; 13 @ISA = qw(Exporter); 14 $VERSION = '1.00'; 15 use constant PIDPATH => '/tmp'; 16 use vars '%CHILDREN'; 17 my ($pid,$pidfile,$saved_dir,$CWD); 18 sub init_server { 19 $pidfile = shift; 20 $pidfile = getpidfilename(); 21 my $fh = open_pid_file($pidfile); 22 print $fh $$; 23 close $fh; 24 $SIG{CHLD} = \&reap_child; 25 return $pid = $$; 26 } 27 sub launch_child { 28 my $callback = shift; 29 my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP); 30 sigprocmask(SIG_BLOCK,$signals); # block inconvenient signals 31 log_die("Can't fork: $!") unless defined (my $child = fork()); 32 if ($child) { 33 $CHILDREN{$child} = $callback 1; 34 } else { 35 $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT'; 36 } 37 sigprocmask (SIG_UNBLOCK,$signals); # unblock signals 38 return $child; 39 } 40 sub reap_child { 41 while ( (my $child = waitpid(-1,WNOHANG)) > 0) { 42 $CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE'; 43 delete $CHILDREN{$child}; 44 } 45 } 46 sub kill_children { 47 kill TERM => $_ foreach keys %CHILDREN; 48 # wait until all the children die 49 sleep while %CHILDREN; 50 } 51 sub do_relaunch { } # no-op 52 sub log_debug { &warn } 53 sub log_notice { &warn } 54 sub log_warn { &warn } 55 sub log_die { &die } 56 sub getpidfilename { 57 my $basename = basename($0,'.pl'); 58 return PIDPATH . "/$basename.pid"; 59 } 60 sub open_pid_file { 61 my $file = shift; 62 if (-e $file) { # oops. pid file already exists 63 my $fh = IO::File->new($file) return; 64 my $pid = <$fh>; 65 croak "Invalid PID file" unless $pid =~ /^(\d+)$/; 66 croak "Server already running with PID $1" if kill 0 => $1; 67 cluck "Removing PID file for defunct server process $pid.\n"; 68 croak "Can't unlink PID file $file" unless -w $file && unlink $file; 69 } 70 return IO::File->new($file,O_WRONLYO_CREATO_EXCL,0644) 71 die "Can't create $file: $!\n"; 72 } 73 END { unlink $pidfile if $$ == $pid } 74 1; 75 __END__ ,'.pl'); 58 return PIDPATH . "/$basename.pid"; 59 } 60 sub open_pid_file { 61 my $file = shift; 62 if (-e $file) { # oops. pid file already exists 63 my $fh = IO::File->new($file) return; 64 my $pid = <$fh>; 65 croak "Invalid PID file" unless $pid =~ /^(\d+)$/; 66 croak "Server already running with PID " if kill 0 => ; 67 cluck "Removing PID file for defunct server process $pid.\n"; 68 croak "Can't unlink PID file $file" unless -w $file && unlink $file; 69 } 70 return IO::File->new($file,O_WRONLYO_CREATO_EXCL,0644) 71 die "Can't create $file: $!\n"; 72 } 73 END { unlink $pidfile if $$ == $pid } 74 1; 75 __END__ |
