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 }