The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
package PackageOne;
use Signals::XSIG qw(untied %XSIG);
use t::SignalHandlerTest;
use Test::More tests => 58;
use Config;
use strict;
use warnings;

# are signal handlers registered correctly when we 
# set $XSIG{signal}[index] directly?

my $sig = appropriate_signals();

my $t = $XSIG{$sig};
ok(tied @{$XSIG{$sig}});

sub foo { 42 }

################### valid signal name ###############

foreach my $func ('DEFAULT', 'IGNORE', '', undef, 'qualified::name',
		  *qualified::glob, \&foo) {

 SKIP: {
    no warnings 'uninitialized';
    if ($Config{PERL_VERSION} == 8 && defined($func)
	&& substr($func,0,1) eq '*') {
      skip '5.8: assign *glob to tied hash not ok', 2;
    }
    $XSIG{$sig}[0] = $func;
    ok($XSIG{$sig}[0] eq $func, "\$XSIG{$sig}[0] assign from $func ok");
    ok($SIG{$sig} eq $XSIG{$sig}[0], 
       '$SIG{sig}/$XSIG{sig}[0] equivalent for ' . $func);
  }

}

$XSIG{$sig}[-10] = 'unqualified_name';
ok($XSIG{$sig}[-10] eq 'main::unqualified_name',
   'unqualfied funcname assignment');

SKIP: {
  if ($Config{PERL_VERSION} == 8) {
    skip '5.8: assignment to tied hash elem from *glob not ok', 1;
  }
  $XSIG{$sig}[23] = *unqualified_glob;
  ok($XSIG{$sig}[23] eq *PackageOne::unqualified_glob);
}

untied {
  ok($SIG{$sig} eq \&Signals::XSIG::__shadow_signal_handler);
};

{
  package Package::Two;
  use Signals::XSIG;
  use Config;

  $XSIG{$sig}[-10] = 'another_unqualified';
  PackageOne::ok($XSIG{$sig}[-10] eq 'main::another_unqualified',
		'assign to unqualified func name');

 SKIP: {
    if ($Config{PERL_VERSION} == 8) {
      Test::More::skip '5.8: assign *glob to tied hash not ok', 1;
    }
    $XSIG{$sig}[0] = *another_unqualified;
    PackageOne::ok($XSIG{$sig}[0] eq *Package::Two::another_unqualified);
  }

}

$XSIG{$sig}[44] = sub { 19 };
ok(ref $XSIG{$sig}[44] eq 'CODE');

delete $XSIG{$sig}[44];
ok(!defined($XSIG{$sig}[44]));

####################### alias signal name ######################

my $alias;
($sig,$alias) = alias_pair();

# diag("sig => $sig, alias => $alias\n");

foreach my $func ('DEFAULT', 'IGNORE', '', undef, 'qualified::name',
		  *qualified::glob, \&foo) {

 SKIP: {
    if ($Config{PERL_VERSION} == 8 && defined($func)
	&& substr($func,0,1) eq '*') {
      skip '5.8: assign *glob to tied hash not ok', 2;
    }

    # assignment to alias or nominal signal name
    # should have the same effect
    if (rand() > 0.5) {
      $XSIG{$alias}[13] = $func;
    } else {
      $XSIG{$sig}[13] = $func;
    }

    no warnings 'uninitialized';
    ok($XSIG{$sig}[13] eq $func);
    ok($XSIG{$alias}[13] eq $func);
  }
}

$XSIG{$alias}[6] = 'unqualified_name';
ok($XSIG{$alias}[6] eq 'main::unqualified_name', 
   'assign unqualified name to alias');
ok($XSIG{$sig}[6] eq $XSIG{$alias}[6]);

SKIP: {
  if ($Config{PERL_VERSION} == 8) {
    skip '5.8: assign *glob to tied hash elem not ok', 2;
  }
  $XSIG{$alias}[8] = *unqualified_glob;
  ok($XSIG{$sig}[8] eq *PackageOne::unqualified_glob,
     'unqualified glob assignment to alias');
  ok($XSIG{$alias}[8] eq $XSIG{$sig}[8]);
}

{
  package Some::Package;
  use Signals::XSIG;
  use Config;

  $XSIG{$sig}[77] = 'another_unqualified';
  PackageOne::ok($XSIG{$sig}[77] eq 'main::another_unqualified');
  PackageOne::ok($XSIG{$alias}[77] eq $XSIG{$sig}[77]);

 SKIP: {
    if ($Config{PERL_VERSION} == 8) {
      Test::More::skip '5.8: assign *glob to tied hash elem not ok', 2;
    }
    $XSIG{$alias}[93] = *another_unqualified;
    PackageOne::ok($XSIG{$alias}[93] eq *Some::Package::another_unqualified);
    PackageOne::ok($XSIG{$sig}[93] eq $XSIG{$alias}[93]);
  }
}

$XSIG{$alias}[33] = sub { 19 };
ok(ref $XSIG{$sig}[33] eq 'CODE');
ok(ref $XSIG{$alias}[33] eq 'CODE');

delete $XSIG{$alias}[33];
ok(!defined $XSIG{$alias}[33]);
ok(!defined $XSIG{$sig}[33]);

ok(tied @{$XSIG{$sig}}, '\@{\$XSIG{sig}} still tied');
ok(tied @{$XSIG{$alias}}, '\@{\$XSIG{alias}} still tied');

#################### bogus signal ###############

no warnings 'signal';
$sig = 'xyz';

ok(!tied $XSIG{$sig});
ok(!defined($XSIG{$sig}));
ok(!defined $SIG{$sig});

$XSIG{$sig}[0] = 'IGNORE';
ok($XSIG{$sig}[0] eq 'IGNORE');
ok(!defined $SIG{$sig});

$XSIG{$sig}[11] = 'foo';
ok($XSIG{$sig}[11] eq 'foo',
   "unqualified assignment to bogus signal not qualified");

delete $XSIG{$sig}[11];
ok(!defined $XSIG{$sig}[11], "\$SIG{$sig} not defined after delete");
ok(!tied $XSIG{$sig});

####################### bogus index #######################