File Coverage

blib/lib/Devel/NoGlobalSig.pm
Criterion Covered Total %
statement 24 26 92.3
branch 4 6 66.6
condition 2 5 40.0
subroutine 6 8 75.0
pod n/a
total 36 45 80.0


line stmt bran cond sub pod time code
1             package Devel::NoGlobalSig;
2             $VERSION = v0.0.1;
3              
4 2     2   1923 use warnings;
  2         4  
  2         86  
5 2     2   12 use strict;
  2         5  
  2         72  
6 2     2   23 use Carp;
  2         6  
  2         327  
7              
8             =head1 NAME
9              
10             Devel::NoGlobalSig - croak when a global %SIG is installed
11              
12             =head1 SYNOPSIS
13              
14             This is a diagnostic tool for detecting where some code has over-written
15             a singnal handler (in the global %SIG) without using local().
16              
17             perl -MDevel::NoGlobalSig=die your_program
18              
19             =head1 ABOUT
20              
21             The installation of global signal handlers by some distant code can be
22             rather surprising. This gives you a way to detect where this happened
23             by installing an exploding subroutine in the handler slot.
24              
25             This is a diagnostic tool. It is not recommended to employ this in
26             production code (but if you find a good reason to do that, please drop
27             me a note.)
28              
29             =head1 USAGE
30              
31             Typically, you will simply want to import this from the command line,
32             e.g. when running some test which is mysteriously failing after
33             integrating two pieces of previously working code.
34              
35             perl -MDevel::NoGlobalSig=die t/never_failed_before.t
36              
37             If your frontend code installs its own global handler for good reason,
38             you'll want to import this after that happens (your handler will be
39             wrapped in a protective exploding shell.)
40              
41             BEGIN {$SIG{__DIE__} = \&my_die_handler};
42             use Devel::NoGlobalSig qw(die warn hup);
43              
44             =head2 Signal Names
45              
46             The arguments to import() may be a list of upper-case or lower-case
47             versions of the handler names. The special signals __WARN__ and __DIE__
48             may be passed as simply 'warn' and 'die', respectively.
49              
50             See L for details.
51              
52             =cut
53              
54 2     2   13 use overload '&{}' => sub { shift->{'sub'} }, fallback => 1;
  2     0   4  
  2         28  
  0         0  
55              
56             sub import {
57 4     4   1388 my $package = shift;
58 4         10 my (@args) = @_;
59              
60 4 100       22 @args or return; # XXX croak?
61              
62 3         7 foreach my $name (@args) {
63 3 50 33     17 $name = '__' . $name . '__' if($name eq 'warn' or $name eq 'die');
64 3         5 $name = uc($name);
65              
66             my $self = {
67             name => $name,
68 0     0   0 'sub'=> $SIG{$name} || sub {},
69 3   50     28 };
70 3         23 $SIG{$name} = bless($self, $package);
71             }
72             }
73              
74             my $ended = 0; END {$ended = 1};
75             sub DESTROY {
76 3 50   3   1641 return if($ended);
77              
78 3         4 my $self = shift;
79              
80 3         51 Carp::carp("BZZT: non-localized \$SIG{$self->{name}} assignment");
81 3         28 exit(1);
82             }
83              
84              
85             =head1 AUTHOR
86              
87             Eric Wilhelm @
88              
89             http://scratchcomputing.com/
90              
91             =head1 BUGS
92              
93             If you found this module on CPAN, please report any bugs or feature
94             requests through the web interface at L. I will be
95             notified, and then you'll automatically be notified of progress on your
96             bug as I make changes.
97              
98             If you pulled this development version from my /svn/, please contact me
99             directly.
100              
101             =head1 COPYRIGHT
102              
103             Copyright (C) 2009 Eric L. Wilhelm, All Rights Reserved.
104              
105             =head1 NO WARRANTY
106              
107             Absolutely, positively NO WARRANTY, neither express or implied, is
108             offered with this software. You use this software at your own risk. In
109             case of loss, no person or entity owes you anything whatsoever. You
110             have been warned.
111              
112             =head1 LICENSE
113              
114             This program is free software; you can redistribute it and/or modify it
115             under the same terms as Perl itself.
116              
117             =cut
118              
119             # vi:ts=2:sw=2:et:sta
120             1;