File Coverage

blib/lib/Signal/StackTrace.pm

Criterion	Covered	Total	%
statement	19	23	82.6
branch	1	4	25.0
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	26	33	78.7

########################################################################
# Signal::StackTrace - run a stack dump on a signal.
########################################################################
########################################################################
# housekeeping
########################################################################

package Signal::StackTrace;

use 5.006;

use strict;

use Carp;
use Config;

use Data::Dumper;

########################################################################
# package variables
########################################################################

our $VERSION = 0.04;

my %known_sigz  = ();

@known_sigz{ split ' ', $Config{ sig_name } } = ();

# see perldoc -f caller for the correct order.

my @headerz =
qw
(
    Package
    Filename
    Line-No
    Subroutine
    Hasargs
    Wantarray
    Evaltext
    Require
    Hints
    Bitmask
);

########################################################################
# private utility subs
########################################################################

my $print_list
= sub
{
    local $Data::Dumper::Purity     = 0;
    local $Data::Dumper::Terse      = 1;
    local $Data::Dumper::Indent     = 1;
    local $Data::Dumper::Deparse    = 1;
    local $Data::Dumper::Sortkeys   = 1;
    local $Data::Dumper::Deepcopy   = 0;
    local $Data::Dumper::Quotekeys  = 0;

    print STDERR join "\n", map { ref $_ ? Dumper $_ : $_ } @_
};

my $stack_trace
= sub
{
    my %data = ();

    for( my $i = 0 ; my @caller = caller $i ; ++$i )
    {
        @data{ @headerz } = @caller;

        $print_list->( "Caller level $i:", \%data );
    }

    $print_list->( "End of trace" );

    return
};

########################################################################
# install the signal handlers
########################################################################

sub import
{
    # discard this package;
    # remainder of the stack are signal names.

    shift;

    if( @_ )
    {
        if( my @junk = grep { ! exists $known_sigz{ $_ } } @_ )
        {
            croak "Unknown signals: unknown signals @junk";
        }

        # all the signals are known, install them all
        # with the stack_trace handler.

        @SIG{ @_ } = ( $stack_trace ) x @_;
    }
    else
    {
        $SIG{ USR1 } = $stack_trace;
    }

    return
}

# keep require happy

1

__END__