1#!perl -w 2 3# We assume that TestInit has been used. 4 5BEGIN { 6 chdir 't' if -d 't'; 7 require './test.pl'; 8} 9 10use strict; 11use Config; 12 13plan tests => 29; 14$| = 1; 15 16watchdog(25); 17 18$SIG{ALRM} = sub { 19 die "Alarm!\n"; 20}; 21 22pass('before the first loop'); 23 24alarm 2; 25 26eval { 27 1 while 1; 28}; 29 30is($@, "Alarm!\n", 'after the first loop'); 31 32pass('before the second loop'); 33 34alarm 2; 35 36eval { 37 while (1) { 38 } 39}; 40 41is($@, "Alarm!\n", 'after the second loop'); 42 43SKIP: { 44 skip('We can\'t test blocking without sigprocmask', 17) 45 if is_miniperl() || !$Config{d_sigprocmask}; 46 skip("This doesn\'t work on $^O threaded builds RT#88814", 17) 47 if ($^O =~ /cygwin/ && $Config{useithreads}); 48 skip("This doesn\'t work on $^O version $Config{osvers} RT#88814", 17) 49 if ($^O eq "openbsd" && $Config{osvers} < 5.2); 50 51 require POSIX; 52 my $pending = POSIX::SigSet->new(); 53 is POSIX::sigpending($pending), '0 but true', 'sigpending'; 54 is $pending->ismember(&POSIX::SIGUSR1), 0, 'SIGUSR1 is not pending'; 55 my $new = POSIX::SigSet->new(&POSIX::SIGUSR1); 56 POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new); 57 58 my $gotit = 0; 59 $SIG{USR1} = sub { $gotit++ }; 60 kill 'SIGUSR1', $$; 61 is $gotit, 0, 'Haven\'t received third signal yet'; 62 63 diag "2nd sigpending crashes on cygwin" if $^O eq 'cygwin'; 64 is POSIX::sigpending($pending), '0 but true', 'sigpending'; 65 is $pending->ismember(&POSIX::SIGUSR1), 1, 'SIGUSR1 is pending'; 66 67 my $old = POSIX::SigSet->new(); 68 POSIX::sigsuspend($old); 69 is $gotit, 1, 'Received third signal'; 70 is POSIX::sigpending($pending), '0 but true', 'sigpending'; 71 is $pending->ismember(&POSIX::SIGUSR1), 0, 'SIGUSR1 is no longer pending'; 72 73 { 74 kill 'SIGUSR1', $$; 75 local $SIG{USR1} = sub { die "FAIL\n" }; 76 POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old); 77 ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is blocked'; 78 eval { POSIX::sigsuspend(POSIX::SigSet->new) }; 79 is $@, "FAIL\n", 'Exception is thrown, so received fourth signal'; 80 POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old); 81TODO: 82 { 83 local $::TODO = "Needs investigation" if $^O eq 'VMS'; 84 ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is still blocked'; 85 } 86 } 87 88 POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new); 89 kill 'SIGUSR1', $$; 90 is $gotit, 1, 'Haven\'t received fifth signal yet'; 91 POSIX::sigprocmask(&POSIX::SIG_UNBLOCK, $new, $old); 92 ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 was still blocked'; 93 is $gotit, 2, 'Received fifth signal'; 94 95 # test unsafe signal handlers in combination with exceptions 96 97 SKIP: { 98 # #89718: on old linux kernels, this test hangs. No-ones thought 99 # of a reliable way to probe for this, so for now, just skip the 100 # tests on production releases 101 skip("some OSes hang here", 3) if (int($]*1000) & 1) == 0; 102 103 SKIP: { 104 skip("Issues on Android", 3) if $^O =~ /android/; 105 my $action = POSIX::SigAction->new(sub { $gotit--, die }, POSIX::SigSet->new, 0); 106 POSIX::sigaction(&POSIX::SIGALRM, $action); 107 eval { 108 alarm 1; 109 my $set = POSIX::SigSet->new; 110 POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $set); 111 is $set->ismember(&POSIX::SIGALRM), 0, "SIGALRM is not blocked on attempt $_"; 112 POSIX::sigsuspend($set); 113 } for 1..2; 114 is $gotit, 0, 'Received both signals'; 115 } 116} 117} 118 119SKIP: { 120 skip("alarm cannot interrupt blocking system calls on $^O", 2) 121 if $^O =~ /MSWin32|cygwin|VMS/; 122 # RT #88774 123 # make sure the signal handler's called in an eval block *before* 124 # the eval is popped 125 126 $SIG{'ALRM'} = sub { die "HANDLER CALLED\n" }; 127 128 eval { 129 alarm(2); 130 select(undef,undef,undef,10); 131 }; 132 alarm(0); 133 is($@, "HANDLER CALLED\n", 'block eval'); 134 135 eval q{ 136 alarm(2); 137 select(undef,undef,undef,10); 138 }; 139 alarm(0); 140 is($@, "HANDLER CALLED\n", 'string eval'); 141} 142 143eval { $SIG{"__WARN__\0"} = sub { 1 } }; 144like $@, qr/No such hook: __WARN__\\0 at/, q!Fetching %SIG hooks with an extra trailing nul is nul-clean!; 145 146eval { $SIG{"__DIE__\0whoops"} = sub { 1 } }; 147like $@, qr/No such hook: __DIE__\\0whoops at/; 148 149{ 150 use warnings; 151 my $w; 152 local $SIG{__WARN__} = sub { $w = shift }; 153 154 $SIG{"KILL\0"} = sub { 1 }; 155 like $w, qr/No such signal: SIGKILL\\0 at/, 'Arbitrary signal lookup through %SIG is clean'; 156} 157 158# [perl #45173] 159{ 160 my $int_called; 161 local $SIG{INT} = sub { $int_called = 1; }; 162 $@ = "died"; 163 is($@, "died"); 164 kill 'INT', $$; 165 # this is needed to ensure signal delivery on MSWin32 166 sleep(1); 167 is($int_called, 1); 168 is($@, "died"); 169} 170