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(25);
  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   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
 117 SKIP: {
 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
 141 eval { $SIG{"__WARN__\0"} = sub { 1 } };
 142 like $@, qr/No such hook: __WARN__\\0 at/, q!Fetching %SIG hooks with an extra trailing nul is nul-clean!;
 143
 144 eval { $SIG{"__DIE__\0whoops"} = sub { 1 } };
 145 like $@, 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 }