File Coverage

blib/lib/Signals/XSIG.pm

Criterion	Covered	Total	%
statement	226	259	87.2
branch	55	82	67.0
condition	33	68	48.5
subroutine	53	63	84.1
pod	0	2	0.0
total	367	474	77.4

package Signals::XSIG;

## no critic (RequireLocalizedPunctuationVars, ProhibitAutomaticExport)

use Signals::XSIG::Default;
use Carp;
use Config;
use Exporter;
use Symbol;
use warnings;
use strict;
require Signals::XSIG::Meta;

our @ISA = qw(Exporter);
our @EXPORT = qw(%XSIG);
our @EXPORT_OK = qw(%DEFAULT_BEHAVIOR);

our %DEFAULT_BEHAVIOR;
*DEFAULT_BEHAVIOR = \%Signals::XSIG::Default::DEFAULT_BEHAVIOR;

our $VERSION = '1.00';
our (%XSIG);
our (%OSIG, %ZSIG, %SIGTABLE, %alias, $_REFRESH);
my (%OOSIG, %YSIG, $_DISABLE_WARNINGS);
our $_INITIALIZED = 0;

# singleton tied hash classes
our $SIGTIE = bless {}, 'Signals::XSIG::TieSIG';
our $XSIGTIE = bless {}, 'Signals::XSIG::TieXSIG';

###
# to be removed when we get a handle on intermittent t/02 failures
our ($XDEBUG,$XN,@XLOG) = ($ENV{XSIGDEBUG},1001);
sub XLOG{
    no warnings "uninitialized";
    push @XLOG,($XN++)." @_";
    XLOG_DUMP() if $XDEBUG>1
}
sub XLOG_DUMP{my $r=join("\n",@XLOG);@XLOG=();Test::More::diag($r)}
###


BEGIN {
    # how to detect global destruction. Idea from Devel::GlobalDestruction 0.13
    if (defined ${^GLOBAL_PHASE}) {
        eval 'sub __inGD() {${^GLOBAL_PHASE} eq "DESTRUCT" && __END()}; 1';
    } else {
        require B;
        eval 'sub __inGD() { ${B::main_cv()}==0 && __END();}; 1';
    }
}

sub import {
    Signals::XSIG->export_to_level(1, @_);
    _init();
}

sub unimport {
    untie %main::SIG;
}

sub _init {
    return if $_INITIALIZED;
    $_REFRESH = 0;
    if ($ENV{XSIG_56} || $Config{PERL_VERSION} <= 6) {
        print STDERR "Using  Signals::XSIG::Meta56  to manage multi-handlers\n";
	require Signals::XSIG::Meta56;
    }

    my @z = ();
    my @num = split ' ', $Config{sig_num};
    my @name = split ' ', $Config{sig_name};
    for (my $i=0; $i<@name; $i++) {
	my $signo = $num[$i];
	my $signame = $name[$i];
	$SIGTABLE{$signo} ||= $signame;
	$SIGTABLE{'SIG' . $signame} = $SIGTABLE{$signame} = $SIGTABLE{$signo};
	if (defined $z[$signo]) {
	    $alias{$signame} = $z[$signo];
	    $alias{$z[$signo]} = $signame;
	    $alias{"pk:$z[$signo]"} = 1;
            $alias{"sub:$signame"} = 1;
	}
	$z[$signo] = $signame;
    }
    $SIGTABLE{'__WARN__'} = '__WARN__';
    $SIGTABLE{'__DIE__'} = '__DIE__';

    *OSIG = \%main::SIG;
    %OOSIG = %OSIG;

    foreach my $sig ('__WARN__', '__DIE__', @name) {
	next if $SIGTABLE{$sig} ne $sig;
	$ZSIG{$sig} = Signals::XSIG->_new($sig, $OSIG{$sig});
    }
    *main::SIG = \%YSIG;
    tie %SIG, 'Signals::XSIG::TieSIG';
    tie %XSIG, 'Signals::XSIG::TieXSIG';
    $_REFRESH = 1;
    $_->_refresh foreach values %ZSIG;
    return ++$_INITIALIZED;
}

END { &__END; }

sub __END {
    no warnings 'redefine';
    *__inGD = sub () { 1 };
}

sub Signals::XSIG::_sigaction {  # function, not method
    my ($signal, @args) = @_;
    foreach my $handler (@{$ZSIG{$signal}->{xh}}) {
	# print STDERR "_sigaction($signal) => $handler\n";
	if ($handler eq 'DEFAULT') {
	    Signals::XSIG::Default::perform_default_behavior(
		$signal, @args);
	} elsif ($signal ne '__WARN__' && $signal ne '__DIE__') {
            no strict 'refs';
	    $handler->($signal, @args);
	} else {
            no warnings 'uninitialized';
            no strict 'refs';
            print STDERR "Calling $signal signal handler $handler \@args=@args\n";
	    $handler->($signal, @args);
	}
    }
}


# convert a signal name to its canonical name. If not disabled,
# warn if the input is not a valid signal name.
#      TERM => TERM
#      CLD  => CHLD
#      OOK  => warning
sub _resolve_signal {
    my ($sig, $DISABLE_WARNINGS) = @_;
    $DISABLE_WARNINGS ||= $_DISABLE_WARNINGS;
    $sig = $SIGTABLE{uc $sig};
    if (defined $sig) {
	$_[0] = $sig;  ## no critic (Unpacking)
	return 1;
    }
    return 1 if !$_INITIALIZED;

    # signal could not be resolved -- issue warning and return false
    unless ($DISABLE_WARNINGS) {
	if (defined($sig) && $sig =~ /\d/ && $sig !~ /\D/) {
	    carp "Invalid signal number $sig.\n";
	} elsif (warnings::enabled('signal')) {
	    Carp::cluck "Invalid signal name $sig.\n";
	}
    }
    return;
}


# in %SIG and %XSIG assignments, string values are qualified to the
# 'main' package, unqualified *glob values are qualified to the
# calling package.
sub _qualify_handler {
    my $handler = shift(@_);

    if (!defined($handler)
	|| $handler eq ''
	|| $handler eq 'IGNORE'
	|| $handler eq 'DEFAULT') {
	return $handler;
    }

    if (substr($handler,0,1) eq '*') {
	my $n = 0;
	my $package = caller;
	while (defined($package) && $package =~ /^Signals::XSIG/) {
	    $package = caller(++$n);
	}
	$handler = Symbol::qualify($handler, $package || 'main');
    } else {
	$handler = Symbol::qualify($handler, 'main');
    }
    return $handler;
}

#####################################################
#
# Signals::XSIG::TieSIG
#
# Only for tie-ing %SIG.
# Associates $SIG{key} with $XSIG{$sig}[0]
#

sub Signals::XSIG::TieSIG::TIEHASH {
    $XDEBUG && XLOG("TieSIG::TIE caller=",caller);
    return $SIGTIE;
}

# called when we say  $x = $SIG{signal}
sub Signals::XSIG::TieSIG::FETCH {
    my ($self,$key) = @_;

    # track function calls to diagnose test failures
    $XDEBUG && $key ne '__DIE__'
            && XLOG("FETCH key=$key caller=",caller);
    if (_resolve_signal($key)) {
	my $old = $ZSIG{$key}->_fetch(0);
        $XDEBUG && $key ne '__DIE__' && XLOG("    result(1)=",$old);
	return $old;
    } else {
	no warnings 'uninitialized';
	my $r = $OSIG{$key};
        $XDEBUG && $key ne '__DIE__' && XLOG("    result(2)=$r");
	return $r;
    }
}

# called when we say  $SIG{signal} = handler
sub Signals::XSIG::TieSIG::STORE {
    my ($self,$key,$value) = @_;
    no warnings 'uninitialized';
    $XDEBUG && $key ne '__DIE__'
        && XLOG("STORE($key,$value) caller=",caller);
    if (_resolve_signal($key)) {
	return $ZSIG{$key}->_store(0, $value);
    } else {
	my $old;
        $XDEBUG && XLOG("    key $key not resolved");
	no warnings 'signal';          ## no critic (NoWarnings)
	$old = $OSIG{$key};
	$OSIG{$key} = $value;
	return $old;
    }
}

# called when we say   delete $SIG{signal}
sub Signals::XSIG::TieSIG::DELETE {
    my ($self,$key) = @_;
    $XDEBUG && $key ne '__DIE__'
        && XLOG("DELETE key=$key caller=",caller);
    if (_resolve_signal($key)) {
	my $old = $ZSIG{$key}->_store(0, undef);
        $XDEBUG && XLOG("    DELETE result(1)=$old");
	return $old;
    } else {
	my $old = $self->FETCH($key);
	no warnings 'uninitialized';
        $XDEBUG && XLOG("    DELETE result(2)=$old");
	$OSIG{$key} = undef;
	delete $OSIG{$key};
	return $old;
    }
}

# called when we say  %SIG = ();
sub Signals::XSIG::TieSIG::CLEAR {
    my ($self) = @_;
    $XDEBUG && $^O ne "MSWin32" && do {
        XLOG("CLEAR caller=",caller);
        XLOG("    CLEAR init USR1=",@{$ZSIG{USR1}{handlers}});
        XLOG("    CLEAR init USR2=",@{$ZSIG{USR2}{handlers}});
    };

    my @sigs = reverse sort keys %ZSIG;
    $XDEBUG && XLOG("    \@sigs = qw(@sigs);");
    for (@sigs) {
	$ZSIG{$_} = Signals::XSIG->_new($_);
    }

    $XDEBUG && $^O ne 'MSWin32' && do {
        XLOG("    CLEAR final USR1=",@{$ZSIG{USR1}{handlers}});
        XLOG("    CLEAR final USR2=",@{$ZSIG{USR2}{handlers}});
    };
    return;
}

# called when we say   exists $SIG{signal}
sub Signals::XSIG::TieSIG::EXISTS {
    my ($self,$key) = @_;
    $XDEBUG && $key ne '__DIE__'
        && XLOG("EXISTS key=$key caller=",caller);
    return exists $OSIG{$key};
}

sub Signals::XSIG::TieSIG::FIRSTKEY {
    my ($self) = @_;
    $XDEBUG && XLOG("FIRSTKEY caller=",caller);
    my $a = keys %OSIG;
    $XDEBUG && XLOG("    FIRSTKEY result=$a");
    return each %OSIG;
}

sub Signals::XSIG::TieSIG::NEXTKEY {
    my ($self, $lastkey) = @_;
    $XDEBUG && XLOG("NEXTKEY lastkey=$lastkey caller=",caller);
    return each %OSIG;
}

# invoked with   untie %SIG
sub Signals::XSIG::TieSIG::UNTIE {
    no warnings 'uninitialized';
    $XDEBUG && !__inGD() && XLOG("UNTIE caller=",caller);
    *main::SIG = \%Signals::XSIG::OSIG;
    *OSIG = \%YSIG;
    %main::SIG = %OOSIG;
    $_INITIALIZED = 0;
    return;
}

############################################################
#
# Signals::XSIG::TieArray
#
# Creates association between @{$XSIG{signal}} / $XSIG{signal}[index]
# and $ZSIG{signal}
#

sub Signals::XSIG::TieArray::TIEARRAY {
    my ($class, $signal) = @_;
    return bless {key => $signal}, 'Signals::XSIG::TieArray';
}

# Those Perl guys thought of everything.
{
    no warnings 'once';
    $Signals::XSIG::TieArray::NEGATIVE_INDICES = 1;
}

# called with  $x = $XSIG{signal}[index]
sub Signals::XSIG::TieArray::FETCH {
    my ($self, $index) = @_;
    return $ZSIG{$self->{key}}->_fetch($index);
}


# called with  $XSIG{signal}[index] = handler
sub Signals::XSIG::TieArray::STORE {
    my ($self, $index, $handler) = @_;
    return $ZSIG{$self->{key}}->_store($index, $handler);
}

sub Signals::XSIG::TieArray::handlers {
    my $self = shift(@_);
    return @{$self->{handlers}};
}

sub Signals::XSIG::TieArray::FETCHSIZE {
    my ($self) = @_;
    return $ZSIG{$self->{key}}->_size;
}

sub Signals::XSIG::TieArray::STORESIZE { }

sub Signals::XSIG::TieArray::EXTEND { }

# called with  exists $XSIG{signal}[index]
sub Signals::XSIG::TieArray::EXISTS {
    my ($self, $index) = @_;
    my $zsig = $ZSIG{$self->{key}};
    return if $index < $zsig->{start};
    return exists $zsig->{handlers}[$index - $zsig->{start}];
}


# called with   delete $XSIG{signal}[index]
sub Signals::XSIG::TieArray::DELETE {
    my ($self, $index) = @_;
    return $ZSIG{$self->{key}}->_store($index, undef);
}

# called with   $XSIG{signal} = []
#               @{$XSIG{signal}} = ()
sub Signals::XSIG::TieArray::CLEAR {
    my ($self) = @_;
    $ZSIG{$self->{key}} = Signals::XSIG->_new($self->{key});
    return;
}


# called with  unshift @{$XSIG{signal}}, @list
sub Signals::XSIG::TieArray::UNSHIFT {
    my ($self, @list) = @_;
    return $ZSIG{$self->{key}}->_unshift(@list);
}


# called with  pop @{$XSIG{signal}}
sub Signals::XSIG::TieArray::POP {
    my ($self) = @_;
    return $ZSIG{$self->{key}}->_pop;
}


# called with  shift @{$XSIG{signal}}
sub Signals::XSIG::TieArray::SHIFT {
    my $self = shift(@_);
    return $ZSIG{$self->{key}}->_shift;
}


# called with  push @{$XSIG{signal}}, @list
sub Signals::XSIG::TieArray::PUSH {
    my ($self, @list) = @_;
    return $ZSIG{$self->{key}}->_push(@list);
}

sub Signals::XSIG::TieArray::SPLICE { }  # TODO

##################################################################
#
# Signals::XSIG::TieXSIG
#
# $XSIG{sig} must produce a tied array that can be used in these ways:
#
#     $aref = $XSIG{signal}
#     $XSIG{signal} = $aref
#     @{$XSIG{signal}} = @list
#     $h = $XSIG{signal}[index]
#     $XSIG{signal}[index] = $h
#     push|unshift @{$XSIG{signal}}, @list
#     $h = pop|shift @{$XSIG{signal}}
#
#
# Only for tie-ing %XSIG.
# adds behavior to %XSIG hash so we can make assignments to
# $XSIG{sig} so that @{$XSIG{$sig}} is always a
# Signals::XSIG::TieArray
#

sub Signals::XSIG::TieXSIG::TIEHASH {
    return $XSIGTIE;
}

# $aref = $XSIG{signal}

sub Signals::XSIG::TieXSIG::FETCH {
    my ($self,$key) = @_;
    _resolve_signal($key,1);
    return $ZSIG{$key} ? $ZSIG{$key}{ta} : [];
}

# called with  $XSIG{signal} = handler, $XSIG{signal} = [handlers]
sub Signals::XSIG::TieXSIG::STORE {
    my ($self, $key, $value) = @_;
    # print STDERR "\n\aTieXSIG::STORE($key)\n\n";
    _resolve_signal($key,1);
    return unless $ZSIG{$key};
    if (ref $value ne 'ARRAY') {
	$value = [ $value ];
    }
    my $old = $ZSIG{$key}->{handlers};
    $ZSIG{$key} = Signals::XSIG->_new($key, @$value);
    return $old;
}

sub Signals::XSIG::TieXSIG::DELETE {
    my ($self, $key) = @_;
    _resolve_signal($key,1);
    my $old = $ZSIG{$key} && $ZSIG{$key}->{handlers};
    $ZSIG{$key} &&= Signals::XSIG->_new($key);
    return $old;
}

sub Signals::XSIG::TieXSIG::CLEAR {
    my ($self) = @_;
    my @names = keys %ZSIG;
    for my $key (@names) {
	$ZSIG{$key} = Signals::XSIG->_new($key);
    }
    return;
}

sub Signals::XSIG::TieXSIG::EXISTS {
    my ($self,$key) = @_;
    _resolve_signal($key,1);
    return exists $ZSIG{$key};
}

sub Signals::XSIG::TieXSIG::FIRSTKEY {
    my ($self) = @_;
    my $a = keys %ZSIG;
    return each %ZSIG;
}

sub Signals::XSIG::TieXSIG::NEXTKEY {
    my ($self, $lastkey) = @_;
    return each %ZSIG
}


# Signals::XSIG object implementation, all with 'private' functions
# Elements of %ZSIG are objects of this type

sub _new {
    my ($___pkg, $sig, @handlers) = @_;
    if ($ENV{XSIG_56} || $Config{PERL_VERSION} <= 6) {
        return Signals::XSIG::Meta56->_new($sig, @handlers);
    } else {
        return Signals::XSIG::Meta->_new($sig, @handlers);
    }
}


1;

__END__