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 => 26;
  13
  14 watchdog(15);
  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', 17)
  43         if is_miniperl() || !$Config{d_sigprocmask};
  44     skip('This doesn\'t work on OpenBSD threaded builds RT#88814', 17)
  45         if $^O eq 'openbsd' && $Config{useithreads};
  46
  47     require POSIX;
  48     my $pending = POSIX::SigSet->new();
  49     is POSIX::sigpending($pending), '0 but true', 'sigpending';
  50     is $pending->ismember(&POSIX::SIGUSR1), 0, 'SIGUSR1 is not pending';
  51     my $new = POSIX::SigSet->new(&POSIX::SIGUSR1);
  52     POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new);
  53
  54     my $gotit = 0;
  55     $SIG{USR1} = sub { $gotit++ };
  56     kill 'SIGUSR1', $$;
  57     is $gotit, 0, 'Haven\'t received third signal yet';
  58     is POSIX::sigpending($pending), '0 but true', 'sigpending';
  59     is $pending->ismember(&POSIX::SIGUSR1), 1, 'SIGUSR1 is pending';
  60
  61     my $old = POSIX::SigSet->new();
  62     POSIX::sigsuspend($old);
  63     is $gotit, 1, 'Received third signal';
  64     is POSIX::sigpending($pending), '0 but true', 'sigpending';
  65     is $pending->ismember(&POSIX::SIGUSR1), 0, 'SIGUSR1 is no longer pending';
  66
  67         {
  68                 kill 'SIGUSR1', $$;
  69                 local $SIG{USR1} = sub { die "FAIL\n" };
  70                 POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old);
  71                 ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is blocked';
  72                 eval { POSIX::sigsuspend(POSIX::SigSet->new) };
  73                 is $@, "FAIL\n", 'Exception is thrown, so received fourth signal';
  74                 POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $old);
  75 TODO:
  76             {
  77                 local $::TODO = "Needs investigation" if $^O eq 'VMS';
  78                 ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 is still blocked';
  79             }
  80         }
  81
  82     POSIX::sigprocmask(&POSIX::SIG_BLOCK, $new);
  83     kill 'SIGUSR1', $$;
  84     is $gotit, 1, 'Haven\'t received fifth signal yet';
  85     POSIX::sigprocmask(&POSIX::SIG_UNBLOCK, $new, $old);
  86     ok $old->ismember(&POSIX::SIGUSR1), 'SIGUSR1 was still blocked';
  87     is $gotit, 2, 'Received fifth signal';
  88
  89     # test unsafe signal handlers in combination with exceptions
  90     my $action = POSIX::SigAction->new(sub { $gotit--, die }, POSIX::SigSet->new, 0);
  91     POSIX::sigaction(&POSIX::SIGALRM, $action);
  92     eval {
  93         alarm 1;
  94         my $set = POSIX::SigSet->new;
  95         POSIX::sigprocmask(&POSIX::SIG_BLOCK, undef, $set);
  96         is $set->ismember(&POSIX::SIGALRM), 0, "SIGALRM is not blocked on attempt $_";
  97         POSIX::sigsuspend($set);
  98     } for 1..2;
  99     is $gotit, 0, 'Received both signals';
 100 }
 101
 102 SKIP: {
 103     skip("alarm cannot interrupt blocking system calls on $^O", 2)
 104         if ($^O eq 'MSWin32' || $^O eq 'VMS');
 105     # RT #88774
 106     # make sure the signal handler's called in an eval block *before*
 107     # the eval is popped
 108
 109     $SIG{'ALRM'} = sub { die "HANDLER CALLED\n" };
 110
 111     eval {
 112         alarm(2);
 113         select(undef,undef,undef,10);
 114     };
 115     alarm(0);
 116     is($@, "HANDLER CALLED\n", 'block eval');
 117
 118     eval q{
 119         alarm(2);
 120         select(undef,undef,undef,10);
 121     };
 122     alarm(0);
 123     is($@, "HANDLER CALLED\n", 'string eval');
 124 }
 125
 126 eval { $SIG{"__WARN__\0"} = sub { 1 } };
 127 like $@, qr/No such hook: __WARN__\\0 at/, q!Fetching %SIG hooks with an extra trailing nul is nul-clean!;
 128
 129 eval { $SIG{"__DIE__\0whoops"} = sub { 1 } };
 130 like $@, qr/No such hook: __DIE__\\0whoops at/;
 131
 132 {
 133     use warnings;
 134     my $w;
 135     local $SIG{__WARN__} = sub { $w = shift };
 136
 137     $SIG{"KILL\0"} = sub { 1 };
 138     like $w, qr/No such signal: SIGKILL\\0 at/, 'Arbitrary signal lookup through %SIG is clean';
 139 }