This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Missing bug number in d12b49d
[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 => 15;
13
14 watchdog(10);
15
16 $SIG{ALRM} = sub {
17     die "Alarm!\n";
18 };
19
20 pass('before the first loop');
21
22 alarm 2;
23
24 eval {
25     1 while 1;
26 };
27
28 is($@, "Alarm!\n", 'after the first loop');
29
30 pass('before the second loop');
31
32 alarm 2;
33
34 eval {
35     while (1) {
36     }
37 };
38
39 is($@, "Alarm!\n", 'after the second loop');
40
41 SKIP: {
42     skip('We can\'t test blocking without sigprocmask', 11)
43         if is_miniperl() || !$Config{d_sigprocmask};
44
45     require POSIX;
46     my $new = POSIX::SigSet->new(&POSIX::SIGUSR1);
47     POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new);
48     
49     my $gotit = 0;
50     $SIG{USR1} = sub { $gotit++ };
51     kill SIGUSR1, $$;
52     is $gotit, 0, 'Haven\'t received third signal yet';
53     
54     my $old = POSIX::SigSet->new();
55     POSIX::sigsuspend($old);
56     is $gotit, 1, 'Received third signal';
57     
58         {
59                 kill SIGUSR1, $$;
60                 local $SIG{USR1} = sub { die "FAIL\n" };
61                 POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old);
62                 ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is blocked';
63                 eval { POSIX::sigsuspend(POSIX::SigSet->new) };
64                 is $@, "FAIL\n", 'Exception is thrown, so received fourth signal';
65                 POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old);
66 TODO:
67             {
68                 local $::TODO = "Needs investigation" if $^O eq 'VMS';
69                 ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is still blocked';
70             }
71         }
72
73 TODO:
74     {
75         local $::TODO = "Needs investigation" if $^O eq 'VMS';
76         kill SIGUSR1, $$;
77         is $gotit, 1, 'Haven\'t received fifth signal yet';
78         POSIX::sigprocmask(&POSIX::SIG_UNBLOCK, $new, $old);
79         ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 was still blocked';
80     }
81     is $gotit, 2, 'Received fifth signal';
82
83     # test unsafe signal handlers in combination with exceptions
84     my $action = POSIX::SigAction->new(sub { $gotit--, die }, POSIX::SigSet->new, 0);
85     POSIX::sigaction(&POSIX::SIGALRM, $action);
86     eval {
87         alarm 1;
88         my $set = POSIX::SigSet->new;
89         POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $set);
90         is $set->ismember(&POSIX::SIGALRM), 0, "SIGALRM is not blocked on attempt $_";
91         POSIX::sigsuspend($set);
92     } for 1..2;
93     is $gotit, 0, 'Received both signals';
94 }