File Coverage

blib/lib/Sys/SigAction.pm
Criterion Covered Total %
statement 75 86 87.2
branch 22 40 55.0
condition 4 12 33.3
subroutine 17 17 100.0
pod 5 8 62.5
total 123 163 75.4


line stmt bran cond sub pod time code
1             #
2             # Copyright (c) 2004-2013 Lincoln A. Baxter
3             #
4             # You may distribute under the terms of either the GNU General Public
5             # License or the Artistic License, as specified in the Perl README file,
6              
7             package Sys::SigAction;
8             require 5.005;
9 6     6   91891 use strict;
  6         8  
  6         155  
10             #use warnings;
11 6     6   1189 use POSIX qw( :signal_h ceil INT_MAX ) ;
  6         14796  
  6         27  
12             require Exporter;
13 6     6   3643 use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS );
  6         8  
  6         362  
14              
15             #support high resolution time transparently in timeout_call by defining
16             #the function sig_alarm() which calls Time::HiRes::alarm if available
17             #or core alarm with the ceil of the value passed otherwise.
18             #timeout_call uses sig_alarm()
19              
20             #replacement for alarm, factional second arg in floating point format:
21 6     6   1581 use Sys::SigAction::Alarm qw( ssa_alarm );
  6         5  
  6         483  
22             sub sig_alarm
23             {
24 14     14 1 20 my $secs = shift;
25 14         57 ssa_alarm( $secs );
26             }
27              
28             #use Data::Dumper;
29              
30             @ISA = qw( Exporter );
31             @EXPORT_OK = qw( set_sig_handler timeout_call sig_name sig_number sig_alarm );
32             $VERSION = '0.22';
33              
34 6     6   26 use Config;
  6         3  
  6         3421  
35             my %signame = ();
36             my %signo = ();
37             {
38             defined $Config{sig_name} or die "This OS does not support signals?";
39             my $i = 0; # Config prepends fake 0 signal called "ZERO".
40             my @numbers = split( ' ' ,$Config{sig_num} );
41             foreach my $name (split(' ', $Config{sig_name}))
42             {
43             $signo{$name} = $numbers[$i];
44             $signame{$signo{$name}} = $name;
45             #print "name=$name num=" .$numbers[$i] ."\n" ;
46             $i++;
47             }
48             }
49              
50             sub sig_name {
51 2     2 1 9 my ($sig) = @_;
52 2 50       32 return $sig if $sig !~ m/^\d+$/ ;
53 2         13 return $signame{$sig} ;
54             }
55             sub sig_number {
56 51     51 1 53 my ($sig) = @_;
57 51 100       254 return $sig if $sig =~ m/^\d+$/;
58 14         43 return $signo{$sig} ;
59             }
60             #if ( $] < 5008 ) {
61             # #over write definitions of sig_name and sig_number
62             # sub sig_name { warn "sig_name() not supported on perl versions < 5.8.0"; }
63             # sub sig_number { warn "sig_number() not supported on perl versions < 5.8.0"; }
64             #}
65              
66             my $use_sigaction = ( $] >= 5.008 and $Config{d_sigaction} );
67              
68             sub _attrs_warning($)
69             {
70 17     17   24 my ( $attrs ) = @_ ;
71             #my $act = POSIX::SigAction->new( $handler ,$mask ,$attrs->{flags} ,$attrs->{safe} );
72             #steve ( SPURKIS@cpan.org submitted http://rt.cpan.org/Ticket/Display.html?id=19916
73             # puts out the above line is a mis-interpretation of the API for POSIX::SigAcation
74             # so here is the fix (per his suggestion)... lab:
75             #
76             #http://rt.cpan.org/Public/Bug/Display.html?id=21777
77             #2006-09-29: in perl 5.8.0 (RH) $act->safe() is broken
78             # safe is not available until 5.8.2
79             # DAMN... it was in my docs too...
80 17 50       43 if ( exists( $attrs->{safe} ) )
81             {
82 0 0 0     0 if ( ( $] < 5.008002 ) && defined($attrs->{safe}) && $attrs->{safe} )
      0        
83             {
84 0         0 warn "safe mode is not supported in perl versions less than 5.8.2";
85 0         0 delete $attrs->{safe};
86             }
87             }
88              
89             }
90             sub set_sig_handler( $$;$$ )
91             {
92 17     17 1 2002590 my ( $sig ,$handler ,$attrs ) = @_;
93 17 100       62 $attrs = {} if not defined $attrs;
94 17         35 _attrs_warning($attrs);
95 17 50       32 if ( not $use_sigaction )
96             {
97             #warn '$flags not supported in perl versions < 5.8' if $] < 5.008 and defined $flags;
98 0         0 $sig = sig_name( $sig );
99 0         0 my $ohandler = $SIG{$sig};
100 0         0 $SIG{$sig} = $handler;
101 0 0       0 return if not defined wantarray;
102 0         0 return Sys::SigAction->new( $sig ,$ohandler );
103             }
104 17         35 my $act = mk_sig_action( $handler ,$attrs );
105 17         28 return set_sigaction( sig_number($sig) ,$act );
106             }
107             sub mk_sig_action($$)
108             {
109 17     17 0 15 my ( $handler ,$attrs ) = @_;
110 17 50       38 die 'mk_sig_action requires perl 5.8.0 or later' if $] < 5.008;
111 17 50       49 $attrs->{flags} = 0 if not defined $attrs->{flags};
112 17 100       45 $attrs->{mask} = [] if not defined $attrs->{mask};
113             #die '$sig is not defined' if not defined $sig;
114             #$sig = sig_number( $sig );
115 17         24 my @siglist = ();
116 17         16 foreach (@{$attrs->{mask}}) { push( @siglist ,sig_number($_)); };
  17         53  
  4         9  
117 17         110 my $mask = POSIX::SigSet->new( @siglist );
118              
119 17         75 my $act = POSIX::SigAction->new( $handler ,$mask ,$attrs->{flags} );
120              
121             #apply patch suggested by CPAN bugs
122             # http://rt.cpan.org/Ticket/Display.html?id=39599
123             # http://rt.cpan.org/Ticket/Display.html?id=39946 (these are dups)
124             #using safe mode with masking signals still breaks the masking of signals!
125 17 50       116 $act->safe($attrs->{safe}) if defined $attrs->{safe};
126 17         26 return $act;
127             }
128              
129              
130             sub set_sigaction($$)
131             {
132 28     28 0 38 my ( $sig ,$action ) = @_;
133 28 50       62 die 'set_sigaction() requires perl 5.8.0 or later' if $] < 5.008;
134 28 50       51 die '$sig is not defined' if not defined $sig;
135 28 50       97 die '$action is not a POSIX::SigAction' if not UNIVERSAL::isa( $action ,'POSIX::SigAction' );
136 28         41 $sig = sig_number( $sig );
137 28 100       55 if ( defined wantarray )
138             {
139 11         25 my $oact = POSIX::SigAction->new();
140 11         183 sigaction( $sig ,$action ,$oact );
141 11         33 return Sys::SigAction->new( $sig ,$oact );
142             }
143             else
144             {
145 17         247 sigaction( $sig ,$action );
146             }
147             }
148              
149 6     6   24 use constant TIMEDOUT => {};
  6         6  
  6         1579  
150             sub timeout_call( $$@ )
151             {
152 7     7 1 5737 my ( $timeout, $code, @args ) = @_;
153              
154 7 50       21 if (!$timeout) {
155 0         0 &$code(@args);
156 0         0 return 0;
157             }
158              
159 7         8 my $timed_out = 0;
160 7         10 eval {
161 7     4   33 my $sa = set_sig_handler( SIGALRM ,sub { $timed_out = 1; die TIMEDOUT; } );
  4         3100353  
  4         61  
162 7         11 eval {
163 7         11 sig_alarm( $timeout );
164 7         18 &$code(@args);
165             };
166 7         1000191 sig_alarm(0);
167 7 50       50 die $@ if $@;
168             };
169 7 100 100     77 die $@ if $@ and (not ref $@ or $@ != TIMEDOUT);
      33        
170              
171 4         21 return $timed_out;
172             }
173             sub new {
174 11     11 0 16 my ($class,$sig,$act) = @_;
175 11         77 bless { SIG=>$sig ,ACT => $act } ,$class ;
176             }
177             sub DESTROY
178             {
179 11 50   11   2042 if ( $use_sigaction )
180             {
181 11         42 set_sigaction( $_[0]->{'SIG'} ,$_[0]->{'ACT'} );
182             }
183             else
184             {
185             #set it to default if not defined (suppress undefined warning)
186 0 0       0 $SIG{$_[0]->{'SIG'}} = defined $_[0]->{'ACT'} ? $_[0]->{'ACT'} : 'DEFAULT' ;
187             }
188 11         110 return;
189             }
190              
191             1;
192              
193             __END__