Update Time-HiRes Changes for 1.9760
[perl.git] / t / op / sigdispatch.t
1 #!perl -w
2
3 # We assume that TestInit has been used.
4
5 BEGIN {
6       chdir 't' if -d 't';
7       require './test.pl';
8 }
9
10 use strict;
11 use Config;
12
13 plan tests => 29;
14 $| = 1;
15
16 watchdog(25);
17
18 $SIG{ALRM} = sub {
19     die "Alarm!\n";
20 };
21
22 pass('before the first loop');
23
24 alarm 2;
25
26 eval {
27     1 while 1;
28 };
29
30 is($@, "Alarm!\n", 'after the first loop');
31
32 pass('before the second loop');
33
34 alarm 2;
35
36 eval {
37     while (1) {
38     }
39 };
40
41 is($@, "Alarm!\n", 'after the second loop');
42
43 SKIP: {
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);
81 TODO:
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
119 SKIP: {
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
143 eval { $SIG{"__WARN__\0"} = sub { 1 } };
144 like $@, qr/No such hook: __WARN__\\0 at/, q!Fetching %SIG hooks with an extra trailing nul is nul-clean!;
145
146 eval { $SIG{"__DIE__\0whoops"} = sub { 1 } };
147 like $@, 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 }