This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #88814] sigdispatch.t work on openbsd 5.2
[perl5.git] / t / op / sigdispatch.t
CommitLineData
8f3964af
NC
1#!perl -w
2
3# We assume that TestInit has been used.
4
5BEGIN {
6 require './test.pl';
7}
8
9use strict;
0c1bf4c7 10use Config;
8f3964af 11
100c03aa 12plan tests => 29;
6281d426 13$| = 1;
8f3964af 14
011c3814 15watchdog(15);
8f3964af
NC
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');
0c1bf4c7
LT
41
42SKIP: {
61fb63a6 43 skip('We can\'t test blocking without sigprocmask', 17)
b93d0e62 44 if is_miniperl() || !$Config{d_sigprocmask};
054559e9
TC
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};
0c1bf4c7
LT
48
49 require POSIX;
61fb63a6
NC
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';
0c1bf4c7
LT
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++ };
eb796c7f 58 kill 'SIGUSR1', $$;
7fe50b8b 59 is $gotit, 0, 'Haven\'t received third signal yet';
0ac0889d
RU
60
61 diag "2nd sigpending crashes on cygwin" if $^O eq 'cygwin';
61fb63a6
NC
62 is POSIX::sigpending($pending), '0 but true', 'sigpending';
63 is $pending->ismember(&POSIX::SIGUSR1), 1, 'SIGUSR1 is pending';
0c1bf4c7
LT
64
65 my $old = POSIX::SigSet->new();
66 POSIX::sigsuspend($old);
67 is $gotit, 1, 'Received third signal';
61fb63a6
NC
68 is POSIX::sigpending($pending), '0 but true', 'sigpending';
69 is $pending->ismember(&POSIX::SIGUSR1), 0, 'SIGUSR1 is no longer pending';
0c1bf4c7 70
7fe50b8b 71 {
eb796c7f 72 kill 'SIGUSR1', $$;
7fe50b8b
LT
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);
23292af3
CB
79TODO:
80 {
81 local $::TODO = "Needs investigation" if $^O eq 'VMS';
7fe50b8b 82 ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is still blocked';
23292af3 83 }
7fe50b8b
LT
84 }
85
554bc0f4 86 POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new);
eb796c7f 87 kill 'SIGUSR1', $$;
554bc0f4
LT
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';
7fe50b8b 91 is $gotit, 2, 'Received fifth signal';
c22d665b
LT
92
93 # test unsafe signal handlers in combination with exceptions
8aed2c65
DM
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 my $action = POSIX::SigAction->new(sub { $gotit--, die }, POSIX::SigSet->new, 0);
102 POSIX::sigaction(&POSIX::SIGALRM, $action);
103 eval {
104 alarm 1;
105 my $set = POSIX::SigSet->new;
106 POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $set);
107 is $set->ismember(&POSIX::SIGALRM), 0, "SIGALRM is not blocked on attempt $_";
108 POSIX::sigsuspend($set);
109 } for 1..2;
110 is $gotit, 0, 'Received both signals';
111 }
0c1bf4c7 112}
011c3814 113
476c37e2
NC
114SKIP: {
115 skip("alarm cannot interrupt blocking system calls on $^O", 2)
0ac0889d 116 if $^O =~ /MSWin32|cygwin|VMS/;
011c3814
DM
117 # RT #88774
118 # make sure the signal handler's called in an eval block *before*
119 # the eval is popped
120
121 $SIG{'ALRM'} = sub { die "HANDLER CALLED\n" };
122
123 eval {
124 alarm(2);
125 select(undef,undef,undef,10);
126 };
127 alarm(0);
128 is($@, "HANDLER CALLED\n", 'block eval');
129
130 eval q{
131 alarm(2);
132 select(undef,undef,undef,10);
133 };
134 alarm(0);
135 is($@, "HANDLER CALLED\n", 'string eval');
136}
84c7b88c
BF
137
138eval { $SIG{"__WARN__\0"} = sub { 1 } };
139like $@, qr/No such hook: __WARN__\\0 at/, q!Fetching %SIG hooks with an extra trailing nul is nul-clean!;
140
141eval { $SIG{"__DIE__\0whoops"} = sub { 1 } };
142like $@, qr/No such hook: __DIE__\\0whoops at/;
143
144{
145 use warnings;
146 my $w;
147 local $SIG{__WARN__} = sub { $w = shift };
148
149 $SIG{"KILL\0"} = sub { 1 };
150 like $w, qr/No such signal: SIGKILL\\0 at/, 'Arbitrary signal lookup through %SIG is clean';
151}
100c03aa
JL
152
153# [perl #45173]
154{
6281d426
TC
155 my $int_called;
156 local $SIG{INT} = sub { $int_called = 1; };
100c03aa
JL
157 $@ = "died";
158 is($@, "died");
6281d426
TC
159 kill 'INT', $$;
160 # this is needed to ensure signal delivery on MSWin32
161 sleep(1);
162 is($int_called, 1);
100c03aa
JL
163 is($@, "died");
164}