This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make the new sigtrap.t test more tolerant of OS differences
[perl5.git] / lib / sigtrap.t
CommitLineData
d1b75174 1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
7cba3dc7 6 require './test.pl';
d1b75174 7}
8
9use strict;
10use Config;
11
7728d0a5 12plan 16;
d1b75174 13
14use_ok( 'sigtrap' );
15
16package main;
17local %SIG;
18
19# use a version of sigtrap.pm somewhat too high
20eval{ sigtrap->import(99999) };
21like( $@, qr/version 99999 required,/, 'import excessive version number' );
22
23# use an invalid signal name
24eval{ sigtrap->import('abadsignal') };
25like( $@, qr/^Unrecognized argument abadsignal/, 'send bad signame to import' );
26
27eval{ sigtrap->import('handler') };
28like( $@, qr/^No argument specified/, 'send handler without subref' );
29
30sigtrap->import('AFAKE');
31is( $SIG{AFAKE}, \&sigtrap::handler_traceback, 'install normal handler' );
32
33sigtrap->import('die', 'AFAKE', 'stack-trace', 'FAKE2');
34is( $SIG{AFAKE}, \&sigtrap::handler_die, 'install the die handler' );
35is( $SIG{FAKE2}, \&sigtrap::handler_traceback, 'install traceback handler' );
36
37my @normal = qw( HUP INT PIPE TERM );
38@SIG{@normal} = 1 x @normal;
39sigtrap->import('normal-signals');
40is( (grep { ref $_ } @SIG{@normal}), @normal, 'check normal-signals set' );
41
42my @error = qw( ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP );
43@SIG{@error} = 1 x @error;
44sigtrap->import('error-signals');
45is( (grep { ref $_ } @SIG{@error}), @error, 'check error-signals set' );
46
47my @old = qw( ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP );
48@SIG{@old} = 1 x @old;
49sigtrap->import('old-interface-signals');
50is( (grep { ref $_ } @SIG{@old}), @old, 'check old-interface-signals set' );
51
52my $handler = sub {};
53sigtrap->import(handler => $handler, 'FAKE3');
54is( $SIG{FAKE3}, $handler, 'install custom handler' );
55
56$SIG{FAKE} = 'IGNORE';
57sigtrap->import('untrapped', 'FAKE');
58is( $SIG{FAKE}, 'IGNORE', 'respect existing handler set to IGNORE' );
59
2227225b
FC
60unlike
61 runperl(
62 switches => [ '-Msigtrap=INT' ],
63 prog => 'sub { kill q-INT-, $$ } -> (3)',
64 stderr => 1
65 ),
66 qr/Modification of a read-only value/,
7728d0a5
FC
67 "stack-trace does not try to modify read-only arguments"
68;
69
d1b75174 70my $out = tie *STDOUT, 'TieOut';
71$SIG{FAKE} = 'DEFAULT';
72$sigtrap::Verbose = 1;
73sigtrap->import('any', 'FAKE');
aa0aae57
FC
74my $read = $out->read;
75untie *STDOUT;
d1b75174 76is( $SIG{FAKE}, \&sigtrap::handler_traceback, 'should set default handler' );
aa0aae57 77like( $read, qr/^Installing handler/, 'does it talk with $Verbose set?' );
d1b75174 78
79# handler_die croaks with first argument
80eval { sigtrap::handler_die('FAKE') };
81like( $@, qr/^Caught a SIGFAKE/, 'does handler_die() croak?' );
82
d1b75174 83package TieOut;
84
85sub TIEHANDLE {
86 bless(\(my $scalar), $_[0]);
87}
88
89sub PRINT {
90 my $self = shift;
91 $$self .= join '', @_;
92}
93
94sub WRITE {
95 my ($self, $msg, $length) = @_;
96 $$self .= $msg;
97}
98
99sub read {
100 my $self = shift;
101 substr($$self, 0, length($$self), '');
102}