ddcc021524dfc99735e52ebcaffed64ba6a75b75
[perl.git] / ext / POSIX / t / sigaction.t
1 #!./perl
2
3 BEGIN{
4         # Don't do anything if POSIX is missing, or sigaction missing.
5         use Config;
6         eval 'use POSIX';
7         if($@ || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' ||
8            $^O eq 'MacOS' || ($^O eq 'VMS' && !$Config{'d_sigaction'})) {
9                 print "1..0\n";
10                 exit 0;
11         }
12 }
13
14 use Test::More tests => 36;
15
16 use strict;
17 use vars qw/$bad $bad7 $ok10 $bad18 $ok/;
18
19 $^W=1;
20
21 sub IGNORE {
22     ++$bad7;
23 }
24
25 sub DEFAULT {
26     ++$bad18;
27 }
28
29 sub foo {
30     ++$ok;
31 }
32
33 my $newaction=POSIX::SigAction->new('::foo', new POSIX::SigSet(SIGUSR1), 0);
34 my $oldaction=POSIX::SigAction->new('::bar', new POSIX::SigSet(), 0);
35
36 {
37         my $bad;
38         local($SIG{__WARN__})=sub { $bad=1; };
39         sigaction(SIGHUP, $newaction, $oldaction);
40         is($bad, undef, "no warnings");
41 }
42
43 like($oldaction->{HANDLER}, qr/\A(?:DEFAULT|IGNORE)\z/, '$oldaction->{HANDLER}');
44
45 is($SIG{HUP}, '::foo');
46
47 sigaction(SIGHUP, $newaction, $oldaction);
48 is($oldaction->{HANDLER}, '::foo');
49
50 ok($oldaction->{MASK}->ismember(SIGUSR1), "SIGUSR1 ismember MASK");
51
52 SKIP: {
53     skip("sigaction() thinks different in $^O", 1)
54         if $^O eq 'linux' || $^O eq 'unicos';
55     is($oldaction->{FLAGS}, 0);
56 }
57
58 $newaction=POSIX::SigAction->new('IGNORE');
59 sigaction(SIGHUP, $newaction);
60 kill 'HUP', $$;
61 is($bad, undef, "SIGHUP ignored");
62
63 is($SIG{HUP}, 'IGNORE');
64 sigaction(SIGHUP, POSIX::SigAction->new('DEFAULT'));
65 is($SIG{HUP}, 'DEFAULT');
66
67 $newaction=POSIX::SigAction->new(sub { ++$ok10; });
68 sigaction(SIGHUP, $newaction);
69 {
70         local($^W)=0;
71         kill 'HUP', $$;
72 }
73 is($ok10, 1, "SIGHUP handler called");
74
75 is(ref($SIG{HUP}), 'CODE');
76
77 sigaction(SIGHUP, POSIX::SigAction->new('::foo'));
78 # Make sure the signal mask gets restored after sigaction croak()s.
79 eval {
80         my $act=POSIX::SigAction->new('::foo');
81         delete $act->{HANDLER};
82         sigaction(SIGINT, $act);
83 };
84 kill 'HUP', $$;
85 is($ok, 1, "signal mask gets restored after croak");
86
87 undef $ok;
88 # Make sure the signal mask gets restored after sigaction returns early.
89 my $x=defined sigaction(SIGKILL, $newaction, $oldaction);
90 kill 'HUP', $$;
91 is($x, '', "signal mask gets restored after early return");
92 is($ok, 1, "signal mask gets restored after early return");
93
94 $SIG{HUP}=sub {};
95 sigaction(SIGHUP, $newaction, $oldaction);
96 is(ref($oldaction->{HANDLER}), 'CODE');
97
98 eval {
99         sigaction(SIGHUP, undef, $oldaction);
100 };
101 is($@, '', "undef for new action");
102
103 eval {
104         sigaction(SIGHUP, 0, $oldaction);
105 };
106 is($@, '', "zero for new action");
107
108 eval {
109         sigaction(SIGHUP, bless({},'Class'), $oldaction);
110 };
111 like($@, qr/\Aaction is not of type POSIX::SigAction/,
112      'any object not good as new action');
113
114 SKIP: {
115     skip("SIGCONT not trappable in $^O", 1)
116         if ($^O eq 'VMS');
117     $newaction=POSIX::SigAction->new(sub { ++$ok10; });
118     if (eval { SIGCONT; 1 }) {
119         sigaction(SIGCONT, POSIX::SigAction->new('DEFAULT'));
120         {
121             local($^W)=0;
122             kill 'CONT', $$;
123         }
124     }
125     is($bad18, undef, "SIGCONT trappable");
126 }
127
128 {
129     local $SIG{__WARN__} = sub { }; # Just suffer silently.
130
131     my $hup20;
132     my $hup21;
133
134     sub hup20 { $hup20++ }
135     sub hup21 { $hup21++ }
136
137     sigaction("FOOBAR", $newaction);
138     pass("no coredump, still alive");
139
140     $newaction = POSIX::SigAction->new("hup20");
141     sigaction("SIGHUP", $newaction);
142     kill "HUP", $$;
143     is($hup20, 1);
144
145     $newaction = POSIX::SigAction->new("hup21");
146     sigaction("HUP", $newaction);
147     kill "HUP", $$;
148     is ($hup21, 1);
149 }
150
151 # "safe" attribute.
152 # for this one, use the accessor instead of the attribute
153
154 # standard signal handling via %SIG is safe
155 $SIG{HUP} = \&foo;
156 $oldaction = POSIX::SigAction->new;
157 sigaction(SIGHUP, undef, $oldaction);
158 ok($oldaction->safe, "SIGHUP is safe");
159
160 # SigAction handling is not safe ...
161 sigaction(SIGHUP, POSIX::SigAction->new(\&foo));
162 sigaction(SIGHUP, undef, $oldaction);
163 ok(!$oldaction->safe, "SigAction not safe by default");
164
165 # ... unless we say so!
166 $newaction = POSIX::SigAction->new(\&foo);
167 $newaction->safe(1);
168 sigaction(SIGHUP, $newaction);
169 sigaction(SIGHUP, undef, $oldaction);
170 ok($oldaction->safe, "SigAction can be safe");
171
172 # And safe signal delivery must work
173 $ok = 0;
174 kill 'HUP', $$;
175 is($ok, 1, "safe signal delivery must work");
176
177 SKIP: {
178     eval 'use POSIX qw(%SIGRT SIGRTMIN SIGRTMAX); scalar %SIGRT + SIGRTMIN() + SIGRTMAX()';
179     $@                                  # POSIX did not exort
180     || SIGRTMIN() < 0 || SIGRTMAX() < 0 # HP-UX 10.20 exports both as -1
181     || SIGRTMIN() > $Config{sig_count}  # AIX 4.3.3 exports bogus 888 and 999
182         and skip("no SIGRT signals", 4);
183     cmp_ok(SIGRTMAX(), '>', SIGRTMIN(), "SIGRTMAX > SIGRTMIN");
184     is(scalar %SIGRT, SIGRTMAX() - SIGRTMIN() + 1, "scalar SIGRT");
185     my $sigrtmin;
186     my $h = sub { $sigrtmin = 1 };
187     $SIGRT{SIGRTMIN} = $h;
188     is($SIGRT{SIGRTMIN}, $h, "handler set & get");
189     kill 'SIGRTMIN', $$;
190     is($sigrtmin, 1, "SIGRTMIN handler works");
191 }
192
193 SKIP: {
194     my %siginfo = (
195         signo => SIGHUP,
196         pid => $$,
197         uid => $<,
198     );
199     my %opt_val = ( code => 'SI_USER' );
200     my %always = map +($_ => 1), qw(signo code);
201     my %skip = ( code => { darwin => "not set to SI_USER for kill()" } );
202     $skip{pid}{$^O} = $skip{uid}{$^O} = "not set for kill()"
203         if (($^O.$Config{osvers}) =~ /^darwin[0-8]\./
204             ||
205             ($^O.$Config{osvers}) =~ /^openbsd[0-6]\./
206             ||
207             ($^O eq 'gnu'));
208     my $tests = keys %{{ %siginfo, %opt_val }};
209     eval 'use POSIX qw(SA_SIGINFO); SA_SIGINFO';
210     skip("no SA_SIGINFO", $tests) if $@;
211     skip("SA_SIGINFO is broken on AIX 4.2", $tests) if ($^O.$Config{osvers}) =~ m/^aix4\.2/;
212     skip("SA_SIGINFO is broken on os390", $tests) if ($^O.$Config{osvers}) =~ m/os390/;
213     eval "use POSIX qw($opt_val{$_}); \$siginfo{$_} = $opt_val{$_}"
214         for keys %opt_val;
215     sub hiphup {
216         for my $field (sort keys %{{ %siginfo, %opt_val }}) {
217             SKIP: {
218                 skip("siginfo_t has no $field field", 1)
219                     unless %always{$field} or ($Config{"d_siginfo_si_$field"} || '') eq 'define';
220                 skip("no constant defined for SA_SIGINFO $field value $opt_val{$field}", 1)
221                     unless defined $siginfo{$field};
222                 skip("SA_SIGINFO $field value is wrong on $^O: $skip{$field}{$^O}", 1)
223                     if $skip{$field}{$^O};
224                 is($_[1]->{$field}, $siginfo{$field}, "SA_SIGINFO got right $field")
225             }
226         }
227     }
228     my $act = POSIX::SigAction->new('hiphup', 0, SA_SIGINFO);
229     sigaction(SIGHUP, $act);
230     kill 'HUP', $$;
231 }
232
233 eval { sigaction(-999, "foo"); };
234 like($@, qr/Negative signals/,
235     "Prevent negative signals instead of core dumping");
236
237 # RT 77432 - assertion failure with POSIX::SigAction
238 {
239   local *SIG = {};
240   ok(sigaction(SIGHUP, POSIX::SigAction->new),
241      "sigaction would crash/assert with a replaced %SIG");
242 }