The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Signals::XSIG;
use t::SignalHandlerTest;
use Test::More tests => 11;
use strict;
use warnings;

# we can override what Perl does with  $SIG{sig} = 'DEFAULT'
# by setting  $Signals::XSIG::Default::DEFAULT_BEHAVIOR{sig}.

my $R = '';
my $S = 0;
my %f = ();
my $sig = 'ALRM';
sub CLEAR { $R = '' };
for my $letter ('A' .. 'Z') {
  $f{$letter} = sub { $R .= $letter };
}

$Signals::XSIG::Default::DEFAULT_BEHAVIOR{$sig}
	= sub { $S++; $R = 'DEFAULT' };

##################################################################

$XSIG{$sig}[0] = \&CLEAR;
$XSIG{$sig}[1] = $f{'A'};
$XSIG{$sig}[2] = $f{'B'};
$XSIG{$sig}[3] = $f{'C'};

ok($S==0 && $R eq '', 'no signals trapped yet');
trigger($sig);
ok($S==0 && $R eq 'ABC', '$XSIG{sig}[idx] assignments respected');

delete $XSIG{$sig}[2];
trigger($sig);
ok($S==0 && $R eq 'AC', 'signal handler deleted');

$XSIG{$sig}[7] = $f{'T'};
trigger($sig);
ok($S==0 && $R eq 'ACT', 'signal handler added');


@{$XSIG{$sig}} = (\&CLEAR, 'DEFAULT', $f{F}, $f{O}, $f{O}, 'DEFAULT');
trigger($sig);
ok($S==1, "DEFAULT signal handler called once even if registered twice");
ok($R eq 'DEFAULTFOO', 
   "DEFAULT signal handler called only first time it is encountered");

$XSIG{$sig} = [ $f{B}, undef, $f{A}, 'IGNORE', undef, $f{R}, 'DEFAULT' ];
trigger($sig);
ok($S==2 && $R eq 'DEFAULT', '$XSIG{sig} default override respected');

push @{$XSIG{$sig}}, sub { chop $R; $R .= 'Z' };
trigger($sig);
ok($S==3 && $R eq 'DEFAULZ', 'append @{$XSIG{sig}} works');

##################################################################

# bogus functions should act like ignore.
$R = '';
$S = 0;
$XSIG{$sig} = [ $f{H}, $f{E}, \&bogus, $f{L}, $f{L}, undef, $f{O} ];
trigger($sig);
ok($S==0 && $R eq 'HELLO', '$XSIG{sig} with \&bogus function ok');

$XSIG{$sig} = [ $f{W}, $f{O}, 'bogus', $f{R}, $f{L}, 'DEFAULT', $f{D} ];
trigger($sig);
ok($S==1 && $R eq 'DEFAULTD', '$XSIG{sig} with \'bogus\' function ok');


# $SIG{sig}=*glob is an error on 5.8, but
# $XSIG{sig}[idx]=*glob is ok.
$XSIG{$sig} = [ $f{W}, *bogus, \&CLEAR, $f{F}, $f{O}, undef, $f{O} ];
trigger($sig);
ok($S==1 && $R eq 'FOO', '$XSIG{sig} with *bogus function ok');

##################################################################