Server IP : 85.214.239.14 / Your IP : 3.12.163.23 Web Server : Apache/2.4.62 (Debian) System : Linux h2886529.stratoserver.net 4.9.0 #1 SMP Tue Jan 9 19:45:01 MSK 2024 x86_64 User : www-data ( 33) PHP Version : 7.4.18 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals,pcntl_unshare, MySQL : OFF | cURL : OFF | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : OFF Directory : /usr/share/doc/libnet-server-perl/examples/ |
Upload File : |
#!/usr/bin/perl -w =head1 NAME sigtest.pl - test for safe/unsafe signal handling =head1 SYNOPSIS sigtest.pl SIGNAME SAFE|UNSAFE # (SIGNAME is a standard signal - default is USR1) # (SAFE will use Net::Server::SIG, UNSAFE uses \$SIG{} - default is SAFE) # If the child isn't saying anything, the test is invalid. # If the child dies, look for a core file. # The process will run until it dies or you kill it =head1 DESCRIPTION Recent versions of Perl (5.8 ish) have much better signal handling so the safe signal handling may not be necessary. But on older versions of Perl the safe signal handling was necessary. It still doesn't hurt to use some of the safer practices on newer Perls. =cut use IO::Select (); use IO::Socket (); use Net::Server::SIG qw(register_sig check_sigs); use POSIX (); print "Usage: $0 SIGNAME SAFE|UNSAFE (SIGNAME is a standard signal - default is USR1) (SAFE will use Net::Server::SIG, UNSAFE uses \$SIG{} - default is SAFE) If the child isn't saying anything, the test is invalid. If the child dies, look for a core file. "; my $SIG = shift() || 'USR1'; my $safe = shift() || 'SAFE'; $safe = uc($safe) eq 'UNSAFE' ? undef : 1; my $x = 0; my %hash = (); ### set up a pipe pipe(READ,WRITE); READ->autoflush(1); WRITE->autoflush(1); STDOUT->autoflush(1); my $pid = fork(); die "Couldn't fork [$!]" unless defined $pid; ### see if child left $SIG{CHLD} = sub { print "P ($$): Child died (\$?=$?)\n" while (waitpid(-1, POSIX::WNOHANG()) > 0); }; ### let the parent try to kill the child if( $pid ){ sleep(2); ### for off children to help bombard the child for(1..4){ my $pid2 = fork(); unless( defined $pid2 ){ kill 9, $pid; die "Couldn't fork [$!]"; } unless( $pid2 ){ $SIG{CHLD} = 'DEFAULT'; last; } } print "P ($$): Starting up!\n"; ### kill the child with that signal my $n = 50000; while (1){ last unless kill $SIG, $pid; unless( ++$x % $n ){ print "P ($$): $x SIG_$SIG\'s sent.\n"; print WRITE "$n\n"; } } ### let the child try to stay alive }else{ print "C ($$): Starting up!\n"; my $select = IO::Select->new(); $select->add(\*READ); ### do some variable manipulation in the signal handler my $subroutine = sub { $hash{foo} = "abcde"x10000; $hash{bar} ++; delete $hash{baz}; delete $hash{bar}; }; ### register a signal and see if it will bounce off of the can_read if( $safe ){ print "C ($$): Using SAFE signal handler.\n"; register_sig($SIG => $subroutine); ### This is an unsafe signal handler. See how long ### it can take signals. }else{ print "C ($$): Using UNSAFE signal handler.\n"; $SIG{$SIG} = $subroutine; } my $total = 0; ### loop forever trying to stay alive while ( 1 ){ my @fh = $select->can_read(10); my $key; my $val; ### this is the handler for safe (fine under unsafe also) next if check_sigs() && ! @fh; ### do some hash manipulation delete $hash{foo}; $hash{bar} = 0; $hash{baz} = "abcde"x100000; next unless @fh; my $line = <READ>; chomp($line); $total += $line; print "C ($$): P said \"$line\"\n"; unless( ++$x % 5 ){ print "C ($$): $x lines read. $total SIG's received\n"; } } print "Child is done\n"; }