File Coverage

blib/lib/Devel/TrackSIG.pm

Criterion	Covered	Total	%
statement	32	49	65.3
branch	4	14	28.5
condition			n/a
subroutine	8	11	72.7
pod	2	2	100.0
total	46	76	60.5

package Devel::TrackSIG;
use strict;
use warnings;
use Carp;
eval "use Carp::Heavy;";
require Tie::Hash;
our @ISA = qw(Tie::ExtraHash);

our $VERSION = '0.04';

tie %main::SIG => __PACKAGE__;

our %opt = (
  track_source => 1,
  report_write_access => 0,
);

sub import {
  my $class = shift;
  my %args = @_;

  $opt{$_} = $args{$_} for keys %args;
}


sub DELETE {
  _report($_[0], $_[1], 'DELETE');
  return delete $_[0]->[0]->{$_[1]};
}

sub STORE {
  _report($_[0], $_[1], 'STORE');
  return $_[0]->[0]->{$_[1]} = $_[2];
}

sub CLEAR {
  _report($_[0], '', 'CLEAR');
  %{$_[0]->[0]} = ();
}


sub _report {
  my $obj = shift;
  my $key = shift;
  my $action = shift;


  push @$obj, {} if @$obj < 2;

  my $sources = $obj->[1];

  my $msg = do {
    my $i;
    my @stack;
    while ( my @caller = caller $i++ ) {
      push @stack, sprintf '    %s::%s called at %s line %s', @caller[0,3,1,2];
    }
    "${action}ing signal handler '$key' at\n" . join("\n", @stack );
  };

  if ($opt{track_source}) {
    $sources->{$key} = $msg;
  }
  if ($opt{report_write_access}) {
    print STDERR $msg . "\n";
  }
}

sub get_source {
  my $self = shift;
  my $key = shift;
  print STDERR "Source tracking not enabled. Pass the track_source => 1 option when loading TrackSIG to enable\n"
    if not $opt{track_source};
  return '' if not @{$self} > 1;
  return $self->[1]->{$key};
}

sub dump_all_sources {
  my $self = shift;
  print STDERR "Source tracking not enabled. Pass the track_source => 1 option when loading TrackSIG to enable\n"
    if not $opt{track_source};
  return if not @{$self} > 1;
  my $sources = $self->[1];
  foreach my $key (keys %$sources) {
    print STDERR "\$SIG{$key} was last set at:\n" . $sources->{$key} . "\n\n";
  }
}

1;

__END__