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
1 #!perl -w
2
3 # We assume that TestInit has been used.
4
5 BEGIN {
6       require './test.pl';
7 }
8
9 use strict;
10 use Config;
11
12 plan tests => 29;
13 $| = 1;
14
15 watchdog(15);
16
17 $SIG{ALRM} = sub {
18     die "Alarm!\n";
19 };
20
21 pass('before the first loop');
22
23 alarm 2;
24
25 eval {
26     1 while 1;
27 };
28
29 is($@, "Alarm!\n", 'after the first loop');
30
31 pass('before the second loop');
32
33 alarm 2;
34
35 eval {
36     while (1) {
37     }
38 };
39
40 is($@, "Alarm!\n", 'after the second loop');
41
42 SKIP: {
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);
79 TODO:
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         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     }
112 }
113
114 SKIP: {
115     skip("alarm cannot interrupt blocking system calls on $^O", 2)
116         if $^O =~ /MSWin32|cygwin|VMS/;
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 }
137
138 eval { $SIG{"__WARN__\0"} = sub { 1 } };
139 like $@, qr/No such hook: __WARN__\\0 at/, q!Fetching %SIG hooks with an extra trailing nul is nul-clean!;
140
141 eval { $SIG{"__DIE__\0whoops"} = sub { 1 } };
142 like $@, 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 }
152
153 # [perl #45173]
154 {
155     my $int_called;
156     local $SIG{INT} = sub { $int_called = 1; };
157     $@ = "died";
158     is($@, "died");
159     kill 'INT', $$;
160     # this is needed to ensure signal delivery on MSWin32
161     sleep(1);
162     is($int_called, 1);
163     is($@, "died");
164 }