This file is indexed.

/usr/share/perl5/Sys/SigAction.pm is in libsys-sigaction-perl 0.20-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
#
#   Copyright (c) 2004-2013 Lincoln A. Baxter
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file,

package Sys::SigAction;
require 5.005;
use strict;
#use warnings;
use POSIX qw( :signal_h ceil INT_MAX ) ;
require Exporter;
use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS );

#support high resolution time transparently in timeout_call by defining
#the function sig_alarm() which calls Time::HiRes::alarm if available
#or core alarm with the ceil of the value passed otherwise.
#timeout_call uses sig_alarm()

#replacement for alarm, factional second arg in floating point format:
use Sys::SigAction::Alarm qw( ssa_alarm );
sub sig_alarm 
{
   my $secs = shift;
   ssa_alarm( $secs );
}

#use Data::Dumper;

@ISA = qw( Exporter );
@EXPORT_OK = qw( set_sig_handler timeout_call sig_name sig_number sig_alarm );
$VERSION = '0.20';

use Config;
my %signame = ();
my %signo = ();
{
   defined $Config{sig_name} or die "This OS does not support signals?";
   my $i = 0;     # Config prepends fake 0 signal called "ZERO".
   my @numbers = split( ' ' ,$Config{sig_num} );
   foreach my $name (split(' ', $Config{sig_name})) 
   {
      $signo{$name} = $numbers[$i];
      $signame{$signo{$name}} = $name;
      #print "name=$name num=" .$numbers[$i] ."\n" ;
      $i++;
   }
}

sub sig_name {
   my ($sig) = @_;
   return $sig if $sig !~ m/^\d+$/ ;
   return $signame{$sig} ;
}
sub sig_number {
   my ($sig) = @_;
   return $sig if $sig =~ m/^\d+$/;
   return $signo{$sig} ;
}
#if ( $] < 5008 ) {
#   #over write definitions of sig_name and sig_number
#   sub sig_name { warn "sig_name() not supported on perl versions < 5.8.0"; }
#   sub sig_number { warn "sig_number() not supported on perl versions < 5.8.0"; }
#}

my $use_sigaction = ( $] >= 5.008 and $Config{d_sigaction} );

sub _attrs_warning($)
{
   my ( $attrs ) =  @_ ;
   #my $act =  POSIX::SigAction->new( $handler ,$mask ,$attrs->{flags} ,$attrs->{safe} );
   #steve ( SPURKIS@cpan.org submitted  http://rt.cpan.org/Ticket/Display.html?id=19916 
   #  puts out the above line is a mis-interpretation of the API for POSIX::SigAcation
   #  so here is the fix (per his suggestion)... lab:
   #
   #http://rt.cpan.org/Public/Bug/Display.html?id=21777
   #2006-09-29: in perl 5.8.0 (RH) $act->safe() is broken 
   #            safe is not available until 5.8.2
   #            DAMN... it was in my docs too... 
   if ( exists( $attrs->{safe} ) )
   {
      if ( ( $] < 5.008002 ) && defined($attrs->{safe}) && $attrs->{safe} ) 
      {
         warn "safe mode is not supported in perl versions less than 5.8.2";
         delete $attrs->{safe};
      }
   }

}
sub set_sig_handler( $$;$$ )
{
   my ( $sig ,$handler ,$attrs ) = @_;      
   $attrs = {} if not defined $attrs;
   _attrs_warning($attrs);
   if ( not $use_sigaction )
   {
      #warn '$flags not supported in perl versions < 5.8' if $] < 5.008 and defined $flags;
      $sig = sig_name( $sig );
      my $ohandler = $SIG{$sig};
      $SIG{$sig} = $handler;
      return if not defined wantarray;
      return Sys::SigAction->new( $sig ,$ohandler );
   }
   my $act = mk_sig_action( $handler ,$attrs );
   return set_sigaction( sig_number($sig) ,$act );
}
sub mk_sig_action($$)
{
   my ( $handler ,$attrs ) = @_;      
   die 'mk_sig_action requires perl 5.8.0 or later' if $] < 5.008;
   $attrs->{flags} = 0 if not defined $attrs->{flags};
   $attrs->{mask} = [] if not defined $attrs->{mask};
   #die '$sig is not defined' if not defined $sig;
   #$sig = sig_number( $sig );
   my @siglist = ();
   foreach (@{$attrs->{mask}}) { push( @siglist ,sig_number($_)); };
   my $mask = POSIX::SigSet->new( @siglist );

   my $act =  POSIX::SigAction->new( $handler ,$mask ,$attrs->{flags} ); 

   #apply patch suggested by CPAN bugs
   #  http://rt.cpan.org/Ticket/Display.html?id=39599
   #  http://rt.cpan.org/Ticket/Display.html?id=39946 (these are dups)
   #using safe mode with masking signals still breaks the masking of signals!
   $act->safe($attrs->{safe}) if defined $attrs->{safe};
   return $act;
}


sub set_sigaction($$)
{ 
   my ( $sig ,$action  ) = @_;
   die 'set_sigaction() requires perl 5.8.0 or later' if $] < 5.008;
   die '$sig is not defined' if not defined $sig;
   die '$action is not a POSIX::SigAction' if not UNIVERSAL::isa( $action ,'POSIX::SigAction' );
   $sig = sig_number( $sig );
   if ( defined wantarray )
   {
      my $oact = POSIX::SigAction->new();
      sigaction( $sig ,$action ,$oact );
      return Sys::SigAction->new( $sig ,$oact );
   }
   else
   {
      sigaction( $sig ,$action );
   }
}

use constant TIMEDOUT => {};
sub timeout_call( $$@ )
{
   my ( $timeout, $code, @args ) = @_;

   if (!$timeout) {
      &$code(@args);
      return 0;
   }

   my $timed_out = 0;
   eval {
      my $sa = set_sig_handler( SIGALRM ,sub { $timed_out = 1; die TIMEDOUT; } );
      eval {
         sig_alarm( $timeout );
         &$code(@args); 
      };
      sig_alarm(0);
      die $@ if $@;
   };
   die $@ if $@ and (not ref $@ or $@ != TIMEDOUT);

   return $timed_out;
}
sub new {
   my ($class,$sig,$act) = @_;
   bless { SIG=>$sig ,ACT => $act } ,$class ;
}
sub DESTROY 
{
   if ( $use_sigaction )
   {
      set_sigaction( $_[0]->{'SIG'} ,$_[0]->{'ACT'} );
   }
   else
   {
      #set it to default if not defined (suppress undefined warning)
      $SIG{$_[0]->{'SIG'}} = defined $_[0]->{'ACT'} ? $_[0]->{'ACT'} : 'DEFAULT' ;
   }
   return;
}

1;

__END__

=head1 NAME

Sys::SigAction - Perl extension for Consistent Signal Handling

=head1 SYNOPSYS

   #do something non-interrupt able
   use Sys::SigAction qw( set_sig_handler );
   {
      my $h = set_sig_handler( 'INT' ,'mysubname' ,{ flags => SA_RESTART } );
      ... do stuff non-interrupt able
   } #signal handler is reset when $h goes out of scope

or

   #timeout a system call:
   use Sys::SigAction qw( set_sig_handler );
   eval {
      my $h = set_sig_handler( 'ALRM' ,\&mysubname ,{ mask=>[ 'ALRM' ] ,safe=>1 } );
      eval {
         alarm(2)
         ... do something you want to timeout
         alarm(0);
      };
      alarm(0); 
      die $@ if $@;
   }; #signal handler is reset when $h goes out of scope
   if ( $@ ) ...

or

   use Sys::SigAction;
   my $alarm = 0;
   eval {
      my $h = Sys::SigAction::set_sig_handler( 'ALRM' ,sub { $alarm = 1; } );
      eval {
         alarm(2)
         ... do something you want to timeout
         alarm(0);
      };
      alarm(0); 
      die $@ if $@;
   }; #signal handler is reset when $h goes out of scope
   if ( $@ or $alarm ) ...

or

   use Sys::SigAction;
   my $alarm = 0;
   Sys::SigAction::set_sig_handler( 'TERM' ,sub { "DUMMY" } );
   #code from here on uses new handler.... (old handler is forgotten)

or

   use Sys::SigAction qw( timeout_call );
   if ( timeout_call( 5 ,sub { $retval = DoSomething( @args ); } )
   {
      print "DoSomething() timed out\n" ;
   }

or

   #use a floating point (fractional seconds) in timeout_call
   use Sys::SigAction qw( timeout_call );
   if ( timeout_call( 0.1 ,sub { $retval = DoSomething( @args ); } )
   {
      print "DoSomething() timed out\n" ;
   }

=head1 ABSTRACT

This module implements C<set_sig_handler()>, which sets up a signal
handler and (optionally) returns an object which causes the signal
handler to be reset to the previous value, when it goes out of scope.

Also implemented is C<timeout_call()> which takes a timeout value, a
code reference and optional arguments, and executes the code reference
wrapped with an alarm timeout. timeout_call accepts seconds in floating
point format, so you can time out call with a resolution of 0.000001
seconds. If C<Time::HiRes> is not loadable or C<Time::HiRes::ualarm()> does
not work, then the factional part of the time value passed to C<timeout_call()>
will be raise to the next higher integer with POSIX::ceil(). This means
that the shortest a timeout can be in 1 second.
 

Finally, two convenience routines are defined which allow one to get the
signal name from the number -- C<sig_name()>, and get the signal number
from the name -- C<sig_number()>.

=head1 DESCRIPTION

Prior to version 5.8.0 perl implemented 'unsafe' signal handling.
The reason it is consider unsafe, is that there is a risk that a
signal will arrive, and be handled while perl is changing internal
data structures.  This can result in all kinds of subtle and not so
subtle problems.  For this reason it has always been recommended that
one do as little as possible in a signal handler, and only variables
that already exist be manipulated.

Perl 5.8.0 and later versions implements 'safe' signal handling
on platforms which support the POSIX sigaction() function.  This is
accomplished by having perl note that a signal has arrived, but deferring
the execution of the signal handler until such time as it is safe to do
so.  Unfortunately these changes can break some existing scripts, if they
depended on a system routine being interrupted by the signal's arrival.
The perl 5.8.0 implementation was modified further in version 5.8.2.

From the perl 5.8.2 B<perlvar> man page:

   The default delivery policy of signals changed in Perl 5.8.0 
   from immediate (also known as "unsafe") to deferred, also 
   known as "safe signals".  


The implementation of this changed the C<sa_flags> with which
the signal handler is installed by perl, and it causes some
system routines (like connect()) to return EINTR, instead of another error
when the signal arrives.  The problem comes when the code that made 
the system call sees the EINTR code and decides it's going to call it 
again before returning. Perl doesn't do this but some libraries do, including for
instance, the Oracle OCI library.

Thus the 'deferred signal' approach (as implemented by default in
perl 5.8 and later) results in some system calls being
retried prior to the signal handler being called by perl. 
This breaks timeout logic for DBD-Oracle which works with
earlier versions of perl.  This can be particularly vexing, when, for instance,
the host on which a database resides is not available:  C<DBI-E<gt>connect()>
hangs for minutes before returning an error (and cannot even be interrupted
with control-C, even when the intended timeout is only seconds). 
This is because SIGINT appears to be deferred as well.  The
result is that it is impossible to implement open timeouts with code
that looks like this in perl 5.8.0 and later:

   eval {
      eval {
         local $SIG{ALRM} = sub { die "timeout" };
         alarm 2;
         $sth = DBI->connect(...);
         alarm 0;
      };
      alarm 0;
      die if $@;
   };

Or as the author of bug #50628 pointed out, 
might probably better be written as:

   eval {
      local $SIG{ALRM} = sub { die "timeout" };
      eval {
         alarm 2;
         $sth = DBI->connect(...);
         alarm 0;
      };
      alarm 0;
      die if $@;
   };


The solution, if your system has the POSIX sigaction() function,
is to use perl's C<POSIX::sigaction()> to install the signal handler.
With C<sigaction()>, one gets control over both the signal mask, and the
C<sa_flags> that are used to install the handler.  Further, with perl
5.8.2 and later, a 'safe' switch is provided which can be used to ask
for safe(r) signal handling. 
   
Using sigaction() ensures that the system call won't be
resumed after it's interrupted, so long as die is called
within the signal handler.  This is no longer the case when 
one uses C<$SIG{name}> to set signal
handlers in perls >= 5.8.0.

The usage of sigaction() is not well documented however, and in perl
versions less than 5.8.0, it does not work at all. (But that's OK, because
just setting C<$SIG> does work in that case.)  Using sigaction() requires
approximately 4 or 5 lines of code where previously one only had to set
a code reference into the %SIG hash.

Unfortunately, at least with perl 5.8.0, the result is that doing this
effectively reverts to the 'unsafe' signals behavior.  It is not clear
whether this would be the case in perl 5.8.2, since the safe flag can be used
to ask for safe signal handling.  I suspect this separates the logic
which uses the C<sa_flags> to install the handler, and whether deferred
signal handling is used.

The reader should also note, that the behavior of the 'safe' 
attribute is not consistent with what this author expected. 
Specifically, it appears to disable signal masking. This can be
examined further in the t/safe.t and the t/mask.t regression tests.
Never-the-less, Sys::SigAction provides an easy mechanism for
the user to recover the pre-5.8.0 behavior for signal handling, and the
mask attribute clearly works. (see t/mask.t) If one is looking for
specific safe signal handling behavior that is considered broken,
and the breakage can be demonstrated, then a patch to t/safe.t would be 
most welcome.

This module wraps up the POSIX:: routines and objects necessary to call
sigaction() in a way that is as efficient from a coding perspective as just
setting a localized C<$SIG{SIGNAL}> with a code reference.  Further, the
user has control over the C<sa_flags> passed to sigaction().  By default,
if no additional args are passed to sigaction(), then the signal handler
will be called when a signal (such as SIGALRM) is delivered.

Since sigaction() is not fully functional in perl versions less than
5.8, this module implements equivalent behavior using the standard
C<%SIG> array.  The version checking and implementation of the 'right'
code is handled by this module, so the user does not have to write perl
version dependent code.  The attrs hashref argument to set_sig_handler()
is silently ignored, in perl versions less than 5.8.  This module has
been tested with perls as old as 5.005 on solaris.

It is hoped that with the use of this module, your signal handling
behavior can be coded in a way that does not change from one perl version
to the next, and that sigaction() will be easier for you to use.

=head1 Note on "Double evals"

CPAN bug #50628 which was filed against Sys::SigAction-0.11
noting that the sample code was "buggy" because the evals 
that wrapped the code we wanted to timeout
might die for an unanticipated reason, before the alarm could be cleared.
In that case, as the bug writer noted, if the alarm expires before the final alarm(0)
can be called, either the code will completely die because
there is no SIGALRM handler in place to catch the signal, or the
wrong handler (not the local handler) will be called. 

All the code samples in this module have been modified to account for this.  
Additionally we have made the same change in timeout_call() which could
have exhibited this behavior, though the AUTHOR never knowing experienced it.

=head1 FUNCTIONS

=head2  set_sig_handler() 

   $sig ,$handler ,$attrs 
   

Install a new signal handler and (if not called in a void context)
returning a Sys::SigAction object containing the old signal handler,
which will be restored on object destruction.

   $sig     is a signal name (without the 'SIG') or number.

   $handler is either the name (string) of a signal handler
            function or a subroutine CODE reference. 

   $attrs   if defined is a hash reference containing the 
            following keys:

            flags => the flags the passed sigaction

               ex: SA_RESTART (defined in your signal.h)

            mask  => the array reference: signals you
                     do not want delivered while the signal
                     handler is executing

               ex: [ SIGINT SIGUSR1 ] or
               ex: [ qw( INT USR1 ]

            safe  => A boolean value requesting 'safe' signal
                     handling (only in 5.8.2 and greater)
                     earlier versions will issue a warning if
                     you use this  

                     NOTE: This breaks the signal masking

=head2 timeout_call()

   $timeout, $coderef, @args

Given a code reference, and a timeout value (in seconds), timeout_call()
will (in an eval) setup a signal handler for SIGALRM (which will die),
set an alarm clock, and execute the code reference with optional
arguments @args. $timeout (seconds) may be expressed as a floating point
number. 


If Time::HiRes is present and useable, timeout_call() can be used with a
timer resolution of 0.000001 seconds. If HiRes is not loadable, 
Sys::SigAction will "do the right thing" and convert the factional 
seconds to the next higher integer value using the posix ceil() function.


If the alarm goes off the code will be interrupted.  The alarm is
canceled if the code returns before the alarm is fired.  The routine
returns true if the code being executed timed out. (was interrupted).
Exceptions thrown by the code executed are propagated out.

The original signal handler is restored, prior to returning to the caller.

=head2 sig_alarm()

ex:

   sig_alarm( 1.2 ); 

sig_alarm() is a drop in replacement for the standard alarm() function.
The argument may be expressed as a floating point number. 

If Time::HiRes is present and useable, the alarm timers will be set
to the floating point value with a resolution of 0.000001 seconds.  
If Time::HiRes is not available then the a fractional value in the argument will 
be raised to the next higher integer value. 

=head2 sig_name()

Return the signal name (string) from a signal number.

ex:

   sig_name( SIGINT ) returns 'INT'
   

=head2 sig_number()

Return the signal number (integer) from a signal name (minus the SIG part).

ex:

   sig_number( 'INT' ) returns the integer value of SIGINT;


=head1 MULTITHREADED PERL


Sys::SigAction works just fine on perls built with multithread support in 
single threaded perl applications. However, please note that
using Signals in a multi-thread perl application is unsupported.

Read the following from perldoc perlthrtut:

   ... mixing signals and threads may be problematic.
   Implementations are platform-dependent, and even the POSIX semantics
   may not be what you expect (and Perl doesn't even give you the full
   POSIX API).  For example, there is no way to guarantee that a signal
   sent to a multi-threaded Perl application will get intercepted by
   any particular thread.

That said, perl documentation for perl threading discusses a a way of
emulating signals in multi-threaded applications, when safe signals
is in effect. See perldoc threads and search for THREAD SIGNALLING.
I have no test of multithreading and this module.  If you thing they
could used compatibly, and would provide value, patches are welcome.

=head1 AUTHOR

   Lincoln A. Baxter <lab-at-lincolnbaxter-dot-com>

=head1 COPYRIGHT

   Copyright (c) 2004-2013 Lincoln A. Baxter
   All rights reserved.

   You may distribute under the terms of either the GNU General Public
   License or the Artistic License, as specified in the Perl README file,


=head1 SEE ALSO

   perldoc perlvar 
   perldoc POSIX

=head1 NOTE

Recent versions of DBD::Oracle no longer reference this module in the
POD, so DBD::Oracle may now have solved the connection timeout problem
internally. For older versions, the dbd-oracle-timeout.pod file provides
a DBD-Oracle test script, which illustrates the use of this
module with the DBD-Oracle driver.