File Coverage

blib/lib/Signals/XSIG.pm

Criterion	Covered	Total	%
statement	360	399	90.2
branch	108	144	75.0
condition	43	65	66.1
subroutine	62	71	87.3
pod	0	3	0.0
total	573	682	84.0

package Signals::XSIG;

## no critic (RequireLocalizedPunctuationVars, ProhibitAutomaticExport)

use Signals::XSIG::Default;
use Carp;
use Config;
use Exporter;
use POSIX ();
use Symbol qw(qualify);
use Time::HiRes 'time';
use warnings;
use strict;

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

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

our $VERSION = '0.16';
our (%XSIG, %_XSIG, %SIGTABLE, $_REFRESH, $_DISABLE_WARNINGS);
our $_INITIALIZED = 0;
our $SIGTIE = bless {}, 'Signals::XSIG::TieSIG';
our $XSIGTIE = bless {}, 'Signals::XSIG::TieXSIG';
our $TIEARRAY_CLASS = 'Signals::XSIG::TieArray';

my %TIEDSCALARS = (); # map signal names to S::X::TiedScalar objs
my %alias = ();


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


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';
    }
}

&_init;

sub _init {
    return if $_INITIALIZED;
    $_REFRESH = 0;
    if ($Config{PERL_VERSION} <= 6) {
	require Signals::XSIG::TieArray56;
	$TIEARRAY_CLASS = 'Signals::XSIG::TieArray56';
    }

    my @z = ();
    my @num = split ' ', $Config{sig_num};
    my @name = split ' ', $Config{sig_name};
    for (my $i=0; $i<@name; $i++) {
	if (defined $z[$num[$i]]) {
	    $alias{$name[$i]} = $z[$num[$i]];
	    $alias{$z[$num[$i]]} = $name[$i];
	    $alias{"pk:$z[$num[$i]]"} = 1;
	}
	$z[$num[$i]] = $name[$i];
    }

    foreach my $sig (@name, '__WARN__', '__DIE__') {
	tie $_XSIG{$sig}, 'Signals::XSIG::TieScalar', $sig;
#### this functionality all happens within S::X::TieScalar::TIESCALAR now
#	$_XSIG{$sig} = [];
#	tie @{$_XSIG{$sig}}, $TIEARRAY_CLASS, $sig;
#	$_XSIG{$sig}[0] = $SIG{$sig};
    }
    tie %SIG, 'Signals::XSIG::TieSIG';
    $_REFRESH = 1;
    foreach my $sig (@name, '__WARN__', '__DIE__') {
	next if $sig eq 'ZERO';
	unless (eval { (tied @{$_XSIG{$sig}})->_refresh_SIG; 1 }) {
	    Carp::confess "Error initializing \@{\$XSIG{$sig}}!: $@\n";
	}
    }
    tie %XSIG, 'Signals::XSIG::TieXSIG';

    my @signo = split ' ', $Config{sig_num};
    my @signame = split ' ', $Config{sig_name};
    for (my $i=0; $i<@signo; $i++) {
	my $signo = $signo[$i];
	my $signame = $signame[$i];
	$SIGTABLE{$signo} ||= $signame;
	$SIGTABLE{'SIG' . $signame} = $SIGTABLE{$signame} = $SIGTABLE{$signo};
    }
    $SIGTABLE{'__WARN__'} = '__WARN__';
    $SIGTABLE{'__DIE__'} = '__DIE__';
    return ++$_INITIALIZED;
}

sub __shadow__warn__handler {          ## no critic (Unpacking)
    return &__shadow_signal_handler('__WARN__',@_)
}
sub __shadow__die__handler  {          ## no critic (Unpacking)
    return &__shadow_signal_handler('__DIE__',@_)
}

END { &__END; }

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

sub __shadow_signal_handler {
    my ($signal, @args) = @_;

    # %XSIG might be partially or completely untied during global destruction
    return if __inGD();
    my $seen_default = 0;

    my $h = tied @{$XSIG{$signal}};
    my @handlers = $h->handlers;
    my $start = $h->{start} - 1;
    my $ignore_main_default = 0;

    # @HANDLER_SEQUENCE: the handlers that have already processed this signal
    # will using 'local' be sufficient to distinguish handler count when
    # signal handling is interrupted by another signal?
    local @Signals::XSIG::HANDLER_SEQUENCE = ();
    while (@handlers) {
	my $subhandler = shift @handlers;
	$start++;
	next if !defined($subhandler);
	next if $subhandler eq '';
	if ($start != 0) {
	    $ignore_main_default = 1;
	}
	next if $subhandler eq 'IGNORE';
	if ($subhandler eq 'DEFAULT') {
	    if ($start == 0) {
		if ($ignore_main_default) {
		    next;
		}
		if (0 != grep { defined($_) && $_ ne '' } @handlers) {
		    next;
		}
	    }
	    next if $seen_default++;
	    Signals::XSIG::Default::perform_default_behavior($signal, @args);
	    push @Signals::XSIG::HANDLER_SEQUENCE, 'DEFAULT';
	} else {
	    next if !defined &$subhandler;
	    no strict 'refs';                    ## no critic (NoStrict)
	    if ($signal =~ /__\w+__/) {
		$subhandler->(@args);
	    } else {
		$subhandler->($signal, @args);
	    }
	    push @Signals::XSIG::HANDLER_SEQUENCE, $subhandler;
	}
    }
    return;
}

# 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;
}

# execute a block of code while %SIG is temporarily untied.

sub untied (&) {                    ## no critic (SubroutinePrototypes)
    my $BLOCK = shift;

    untie %SIG;
    my @r = wantarray ? $BLOCK->() : scalar $BLOCK->();
    tie %SIG, 'Signals::XSIG::TieSIG';

    return wantarray ? @r : $r[0];
}



# 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 = qualify($handler, $package || 'main');
    } else {
	$handler = 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;
}

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)) {
        $XDEBUG && $key ne '__DIE__' && XLOG("    result(1)=",$_XSIG{$key}[0]);
	return $_XSIG{$key}[0];
    } else {
	no warnings 'uninitialized';
	my $r = untied { $SIG{$key} };
        $XDEBUG && $key ne '__DIE__' && XLOG("    result(2)=$r");
	return $r;
    }
}

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)) {
	my $old = $_XSIG{$key}[0];
	$_XSIG{$key}[0] = $value;
	return $old;
    } else {
	my $old;
        $XDEBUG && XLOG("    key $key not resolved");
	untied {
	    no warnings 'signal';          ## no critic (NoWarnings)
	    $old = $SIG{$key};
	    $SIG{$key} = $value;
	};
	return $old;
    }
}

sub Signals::XSIG::TieSIG::DELETE {
    my ($self,$key) = @_;
    $XDEBUG && $key ne '__DIE__'
        && XLOG("DELETE key=$key caller=",caller);
    if (_resolve_signal($key)) {
	my $old = $_XSIG{$key}[0];
        $XDEBUG && XLOG("    DELETE result(1)=$old");
	$_XSIG{$key}[0] = undef;
	return $old;
    } else {
	my $old = $self->FETCH($key);
	no warnings 'uninitialized';
        $XDEBUG && XLOG("    DELETE result(2)=$old");
	untied {
	    $SIG{$key} = undef;
	    delete $SIG{$key};
	};
	return $old;
    }
}

sub Signals::XSIG::TieSIG::CLEAR {
    my ($self) = @_;
    $XDEBUG && do {
        XLOG("CLEAR caller=",caller);
        XLOG("    CLEAR init USR1=",@{$_XSIG{USR1}});
        XLOG("    CLEAR init USR2=",@{$_XSIG{USR2}});
    };

    # this used to say
    #     $_XSIG{$_}[0] = undef for keys %_XSIG
    # but on some platforms, for a reason I don't yet understand,
    # the signal handler for the first value in the for loop
    # would not get cleared properly. For another reason I don't
    # yet understand, this is apparently not an issue for the
    # __WARN__ and __DIE__ handlers, so we'll manipulate the signal
    # list to make sure those handlers go first.

    my @sigs = reverse sort keys %_XSIG;
    $XDEBUG && XLOG("    \@sigs = qw(@sigs);");
    for (@sigs) {
	$_XSIG{$_}[0] = undef;
    }

    $XDEBUG && do {
        XLOG("    CLEAR final USR1=",@{$_XSIG{USR1}});
        XLOG("    CLEAR final USR2=",@{$_XSIG{USR2}});
    };
    return;
}

sub Signals::XSIG::TieSIG::EXISTS {
    my ($self,$key) = @_;
    $XDEBUG && $key ne '__DIE__'
        && XLOG("EXISTS key=$key caller=",caller);
    return untied { exists $SIG{$key} };
}

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

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

sub Signals::XSIG::TieSIG::UNTIE {
    $XDEBUG && !__inGD() && XLOG("UNTIE caller=",caller);
    return;
}

############################################################
#
# Signals::XSIG::TieArray
#
# Applied to @{$XSIG{signal}}.
# On update, refreshes the handler for the signal.
#

sub Signals::XSIG::TieArray::TIEARRAY {
    my ($class, @list) = @_;
    my $obj = bless {}, 'Signals::XSIG::TieArray';
    $obj->{key} = shift @list;
    $obj->{start} = 0;  # {start} refers to slot for first element of {handlers}
    $obj->{handlers} = [ map { _qualify_handler($_) } @list ];
    return $obj;
}

# Wow. Those Perl guys thought of everything.
$Signals::XSIG::TieArray::NEGATIVE_INDICES = 1;

sub Signals::XSIG::TieArray::FETCH {
    my ($self, $index) = @_;
    $index -= $self->{start};
    return if $index < 0;
    return $self->{handlers}[$index];
}

sub Signals::XSIG::TieArray::STORE {
    my ($self, $index, $handler) = @_;
    $index -= $self->{start};

    while ($index < 0) {
	unshift @{$self->{handlers}}, undef;
	$index++;
	$self->{start}--;
    }

    while ($index > $#{$self->{handlers}}) {
	push @{$self->{handlers}}, undef;
    }

    my $old = $self->{handlers}[$index];

    $handler = _qualify_handler($handler);
    $self->{handlers}[$index] = $handler;
    $XDEBUG
	&& XLOG("TA::STORE key=$self->{key} index=$index val=",$handler,
		" caller=",caller);
    $self->_refresh_SIG();
    return $old;
}

sub Signals::XSIG::TieArray::_refresh_SIG {
    my $self = shift;
    return if $_REFRESH == 0;

    my $sig = $self->{key};
    my @index_list = ();
    my @handlers = @{$self->{handlers}};
    my ($seen_default, $seen_ignore) = (0,0);
    for (my $i=0; $i<@handlers; $i++) {
	next if !defined $handlers[$i];
	next if $handlers[$i] eq 'DEFAULT' && $seen_default++;
	next if $handlers[$i] eq 'IGNORE' && $seen_ignore++;
	push @index_list, $i + $self->{start};
    }

    my $handler_to_install;
    if (@index_list == 0) {
	$handler_to_install = undef;
    }

    # XXX - if there is a single handler, and that handler is 'DEFAULT',
    #       do we want to install the shadow signal handler anyway?
    #       The caller may have overridden the DEFAULT behavior of the signal,
    #       so yeah, I think we do.

    elsif (@index_list == 1 &&
	   ($seen_default == 0 || ref($DEFAULT_BEHAVIOR{$sig}) eq '')) {
	$handler_to_install = $handlers[$index_list[0]];
    } else {
	if ($sig eq '__WARN__') {
	    $handler_to_install = \&Signals::XSIG::__shadow__warn__handler;
	} elsif ($sig eq '__DIE__') {
	    $handler_to_install = \&Signals::XSIG::__shadow__die__handler;
	} else {
	    $handler_to_install = \&Signals::XSIG::__shadow_signal_handler;
	}
    }
    untied {
	no warnings qw(uninitialized signal); ## no critic (NoWarnings)
        $XDEBUG
	    && XLOG("refresh_SIG key=$self->{key} handler=$handler_to_install");
	$SIG{$sig} = $handler_to_install;
    };
    return;
}

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

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

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

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

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

sub Signals::XSIG::TieArray::DELETE {
    my ($self, $index) = @_;
    $index -= $self->{start};
    return if $index < 0;
    my $old = $self->{handlers}[$index];
    $self->{handlers}[$index] = undef;
    $self->_refresh_SIG;
    return $old;
}

sub Signals::XSIG::TieArray::CLEAR {
    my ($self) = @_;
    $self->{handlers} = [];
    $self->{start} = 0;
    $self->_refresh_SIG;
    return;
}

sub Signals::XSIG::TieArray::UNSHIFT {
    my ($self, @list) = @_;
    unshift @{$self->{handlers}}, @list;
    $self->{start} -= @list;
    $self->_refresh_SIG;
    return $self->FETCHSIZE;
}

sub Signals::XSIG::TieArray::POP {
    my ($self) = @_;
    if (@{$self->{handlers}} + $self->{start} <= 1) {
	return;
    }
    my $val = pop @{$self->{handlers}};
    $self->_refresh_SIG;
    return $val;
}

sub Signals::XSIG::TieArray::SHIFT {
    my $self = shift;
    if ($self->{start} >= 0) {
	return;
    }
    my $val = shift @{$self->{handlers}};
    $self->{start}++;
    $self->_refresh_SIG;
    return $val;
}

sub Signals::XSIG::TieArray::PUSH {
    my ($self, @list) = @_;
    if (@{$self->{handlers}} + $self->{start} <= 0) {
	unshift @list, undef;
    }
    my $val = push @{$self->{handlers}}, @list;
    $self->_refresh_SIG;
    return $val;
}

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

##################################################################
#
# Signals::XSIG::TieScalar
#
# For tie-ing $XSIG{signal}.
# Handles expressions like  $XSIG{signal} = [ ... ]
# and                       $XSIG{signal} = handler
# Main purpose is to assert that $XSIG{$sig} is always set
# to a reference to a  Signals::XSIG::TieArray  object.
#

sub Signals::XSIG::TieScalar::TIESCALAR {
    my ($class, @list) = @_;
    my $key = $list[0];
    if (defined($alias{$key}) && !defined($alias{"pk:$key"})) {
	return $TIEDSCALARS{$key} = $TIEDSCALARS{$alias{$key}};
    }

    my $self = bless { key => $key }, 'Signals::XSIG::TieScalar';
    $self->{val} = [];
    tie @{$self->{val}}, $TIEARRAY_CLASS, $key;
    $self->{val}[0] = $SIG{$key};
    $TIEDSCALARS{$key} = $self;
    return $self;
}

sub Signals::XSIG::TieScalar::FETCH {
    my $self = shift;
    my $key = my $key2 = $self->{key};
    Signals::XSIG::_resolve_signal($key);
    if ($key ne $key2 && !$self->{copied}) {
	$self->{val} = (tied $Signals::XSIG::_XSIG{$key})->FETCH;
	$self->{copied} = $key;
        push @{(tied $Signals::XSIG::_XSIG{$key})->{aliases}}, $key2;
    } elsif ($self->{copied}) {
        $self->{val} = $Signals::XSIG::_XSIG{ $self->{copied} };
    }
    return $self->{val};
}

# $XSIG{key} = [ LIST ]   ==>  store LIST, tie LIST as TieArray
# $XSIG{key} = EXPR       ==>  treat as  $SIG{key}=EXPR,$XSIG{key}[0]=EXPR
sub Signals::XSIG::TieScalar::STORE {
    my ($self, $value) = @_;
    my $old = $self->{val};

    if (ref $value ne 'ARRAY') {
	$value = [ $value ];
    }

    my $key = $self->{key};
    $self->{val} = [];
    tie @{$self->{val}}, $TIEARRAY_CLASS, $self->{key}, @$value;
    (tied @{$self->{val}})->_refresh_SIG;
    return $old;
}

##################################################################
#
# Signals::XSIG::TieXSIG
#
# 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;
}

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

sub Signals::XSIG::TieXSIG::STORE {
    my ($self, $key, $value) = @_;
    _resolve_signal($key,1);
    my $old = $_XSIG{$key};
    # (tied $_XSIG{$key})->STORE($key,$value); #
    $_XSIG{$key} = $value;
    return $old;
}

sub Signals::XSIG::TieXSIG::DELETE {
    my ($self, $key) = @_;
    _resolve_signal($key,1);
    my $old = $_XSIG{$key};
    $XSIG{$key} = [];
    return $old;
}

sub Signals::XSIG::TieXSIG::CLEAR {
    my ($self) = @_;

    my @aliases = ();
    for my $xsig (keys %_XSIG) {
	my $osig = $xsig;
	if (_resolve_signal($xsig, 1)) {
	    if ($osig ne $xsig) {
		push @aliases, [$xsig, $osig];
	    } else {
		$XSIG{$xsig} = [];
	    }
	} else {
	    delete $_XSIG{$xsig};
	}
    }
    foreach my $pair (@aliases) {
	my ($xsig, $alias) = @$pair;
	$_XSIG{$alias} = $_XSIG{$xsig};
    }
    return;
}

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

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

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

1;

__END__