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