Sys-SigAction-0.20/0000755000175000017500000000000012177571553012162 5ustar lablabSys-SigAction-0.20/dbd-oracle-timeout.POD0000755000175000017500000004055412173343472016212 0ustar lablab#!/usr/bin/env perl # # Copyright (c) 2004-2009 by Lincoln A Baxter # All rights reserved. # # This file may be distributed under the terms of either the GNU # General Public License or the Artistic License, as specified in # the Perl README file, # use strict; use warnings; use English; undef $RS; my $script = ; $script =~ s,.*#!/usr/bin/env perl\s*,,gs; $script =~ s/#end of test script.*//gs; eval $script; die if $@; exit; __END__ __DATA__ =head1 NAME dbd-oracle-timeout.pod - test timing out DBD-Oracle operations with C =head1 ABTRACT This article discuss the problems I encountered using C to timeout certain DDB-Oracle operations in a in a perl OLTP service. Perl 5.8.0 and later versions on platforms that support sigaction() implements 'safe' signal handling. Unfortunately, techniques that worked in perl versions earlier than 5.8, do not work in perl 5.8 and later versions. Several solutions to this problem are presented. =head1 DESCRIPTION If you are implementing a real-time service, your software must be both responsive, and well behaved from a resource utilization perspective. It is imperative that no operation take a long time to complete, and that resources are quickly freed, so that the service can respond to new requests. In this situation, it is generally preferable to time out or fail returning an error, than to allow requests to hang for long periods of time, potentially bringing down an entire service because system resources are consumed by all the hanging requests. My team has implemented a number of real time services using perl and the DBI interface using the DBD-Oracle driver. This article is specific to the problems encountered with Oracle, but I believe that the problems we encountered on moving from perl 5.6 to perl 5.8, are generic, and could affect any database driver that uses a client library that makes restartable system calls like connect(). The techniques presented here can be used to solve this kind of problem with any DBD driver, or for any system resource that could hang, for which C has been used to break out of the call. Using the DBI interface prior to Perl 5.8.0, it was fairly easy to set code references into C<$SIG{'ALRM'}>, and then use alarm() to implement time-outs. The signal handler could then die() or otherwise abort the call in progress. The two operations I have found that require this treatment are: =over =item 1 Database Host is Down -- connect() hangs With SQL*Net, the Cconnect()> call will hang for about 4 minutes. Here is how we handled this situation in perls earlier than 5.8.x: eval { local $SIG{ALRM} = sub { die "open timed out"; }; eval { alarm(2); #implement 2 second time out $dbh = DBI->connect("dbi:Oracle:$dbn" ... ); alarm(0); }; alarm(0); die $@ if $@; }; if ( $@ ) { print "connection to $dbn timed out\n" ; } Because C<$SIG{ALRM}> has been 'localized', this code restores the original value of C<$SIG{ALRM}> (the original signal handler) when the eval block is exited. =item 2 Long Running Statements Long running statements can occur for a variety of reasons out side of the control of the script. Timing out calls to execute() avoids stacking of resources on the server on which the perl script is executing. The following example is similar to the that above: eval { local $SIG{ALRM} = sub { $sth->cancel(); }; eval { alarm(2); #implement 2 second time out $sth->execute( ... ); alarm(0); }; alarm(0); die $@ if $@; }; if ( $@ ) { print "execute timed out\n" } Again, perl restores the original C<$SIG{ALRM}> handler when the eval block is exited. =back =head2 Note on eval of eval The reader might note that the "double evals" in the code samples above. CPAN bug #50628 was filed against Sys::SigAction 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, 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 here have been adjusted to execute the code to be timed out in an inner eval to correct for this problem. =head2 The Problem Many of us have been using perl 5.6.x for several years now, and the above code has worked just fine. We understood that with perl 5.6 (and prior) signal handling was 'unsafe', and we accepted the risk that the signal handler could be called at an in-opportune time, causing non-reentrant system routines to fail. We accepted the possibility of a perl core dump, and program termination. For real-time services this is considered an acceptable risk since failing quickly is preferable to hanging around without returning. We, like most programmers facing this problem, simply built mechanisms to restart things should such a catastrophic failure (perl core dump) occur. Another technique we use, is to take ourselves out on error, letting a new (clean) instance of our service be created (by the above mechanism). Upon moving to perl 5.8 or higher however, we discovered that the above code (especially the connect code) no longer works. Instead, it just hangs. This is a result of the changes to the way Unix signal handlers are implemented in perl 5.8 (and later versions). From the perl 5.8.2 B 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". Unfortunately this 'safe signals' approach causes some system calls to be retried (depending on how they are called) prior to the actual execution of the signal handler depending on how the library making the system call is implemented. The result when this happens is that some calls never return, even though a signal fired. This is the case with the DBD-Oracle connect() call (case 1 above). So the 'standard' mechanism for implementing time outs (above) no longer works with perl 5.8 and later versions. =head2 The Solution The solution to this problem (documented in the B man page) is to install the signal handler with C. This provides low level access to the POSIX sigaction() system API -- assuming (of course) your system has sigaction(). If your system does not have sigaction(), then you probably do not have this problem, as in that case perl implements the original (unsafe) signal handling approach. With C, we get control over both the signal mask, and the C that are used to install the handler, and further, with perl 5.8.2 and later, a 'safe' switch is provided which can be used to ask for safe signal handling, in which perl promises to call the signal handler between perl op codes. Using C does ensure that the signal handler is called when the signal is fired. Calling die() within the signal handler, will cause the system call will be interrupted, and control will return to the perl script. But doing this effectively implements returns us to the 'unsafe' signals behavior -- at least in perl 5.8.0. In perl 5.8.2, it is possible to ask for 'deferred' signal handling while still controlling the C used to install the signal handler. The does this with perl 5.8.2 is safer than perl 5.6.x. The usage of C however is not well documented (except for several examples in the C test in the perl core). And in perl versions less than 5.8.0, while C is defined, it appears to be broken. But that's OK, because just setting C<$SIG{NAME}> works. =head2 The Pain The down side of using C besides the fact that it does not work in perl versions less than 5.8 is that it requires approximately 4 or 5 lines of code where previously you only had to set a localized C<$SIG{ALRM}>. The C code looks something like this (for the connect() case): use POSIX ':signal_h'; eval { my $mask = POSIX::SigSet->new( SIGALRM ); #list of signals to mask in the handler my $action = POSIX::SigAction->new( sub { die "connect failed" ; } #the handler code ref ,$mask ); #assumes we're not using an specific flags or 'safe' switch my $oldaction = POSIX::SigAction->new(); sigaction( 'ALRM' ,$action ,$oldaction ); eval { alarm(2); #implement 2 second time out $dbh = DBI->connect("dbi:Oracle:$dbn" ... ); alarm(0); }; alarm(0); sigaction( 'ALRM' ,$oldaction ); #restore original signal handler die $@ if $@; }; if ( $@ ) .... This is not a pretty replacement for what was a single line of code in perl 5.6.x and before. And, to make matters worse (because C does not work in perl versions less than 5.8, we now have to make it conditional on the perl version. =head2 The Pain Reliever -- Sys::SigAction Fortunately, having been bitten by this problem, and not wishing to have to replicate all that code every where I had timeout logic, I implemented a module that makes using C as easy as setting a localized C<$SIG{ALRM}> was in perl 5.6.x. The C module can be retrieved from CPAN by going to: http://search.cpan.org/~lbaxter/Sys-SigAction/ The C module wraps up all of the above POSIX:: code into a single function call which returns an object reference. When the object goes out of scope, its destructor resets the signal handler. So the above code is rewritten as follows: use Sys::SigAction qw( set_sig_handler ); eval { my $h = set_sig_handler( 'ALRM' ,sub { die "connect failed" ; } ); eval { alarm(2); #implement 2 second time out $dbh = DBI->connect("dbi:Oracle:$dbn" ... ); alarm(0); }; alarm(0); die $@ if $@; }; #original signal handler restored here when $h goes out of scope if ( $@ ) .... And the nice thing about using C, is that it works with older perls back to perl 5.005. So, even though POSIX::sigaction() is not fully functional in perl versions less than 5.8, C can be used with to facilitate migration to newer perls, while still supporting the older perls. Thus, there is no need to write code conditioned on the perl version, because C does that for you. =head2 Sample Script The following test script illustrates the use of C, with the DBI interface (DBD-Oracle driver) to implement time out of both connects to databases on hosts that are down, and long running sql statements. Note that with Sys::SigAction version 0.06, this script was changed to explicitly set safe=>0 (instead of safe=>1). The reason is that Sys::SigAction (version 0.04 and less) did not correctly set this parameter on the POSIX::sigaction call. When that was fixed with version 0.06 this script had to be fixed. #!/usr/bin/env perl use 5.006; use strict; use warnings; #if your perl is < 5.6 comment this out use Test::More ; use Cwd; use POSIX ':signal_h' ; my $iterations = $ENV{TIMEOUT_TEST_ITERATIONS}; $iterations = 1 if not defined $iterations; my $tests = 9 + ($iterations * 2 ); plan tests => $tests; use_ok('Sys::SigAction'); use_ok('DBI'); ok( $ENV{ORACLE_USERID} ,"ORACLE_USERID (/@) is defined\n" ); die "please export ORACLE_USERID=/@\n" if not defined $ENV{'ORACLE_USERID'}; #find a private IP address which does not respond to ping my $last_octet = 256; my $got_down_host = 0; my $down_host ; do { $last_octet--; $down_host = "10.255.255.$last_octet"; } until $got_down_host = system( "ping -c 1 -t 1 $down_host 2>&1 > /dev/null" ) or $last_octet == 0; ok( $got_down_host ,"Found IP addr ($down_host) for missing system test\n" ); #parse ORACLE_USERID my $dbn=''; my $usr=''; my $pwd=''; ( $usr ,$pwd ,$dbn ) = split( /[\/\@]/ ,$ENV{'ORACLE_USERID'} ); ok( $usr ,"database user: '$usr' defined" ); ok( $pwd ,"password for $usr is defined" ); ok( $dbn ,"database name: '$dbn' defined" ); #I'm lazy... this stuff is unix specific... but then, #if you are using SigAction that is pretty unix specific too! # #we need a locally writeable tns_admin directory #so we copy it from $TNS_ADMIN and then redefine #TNS_ADMIN to the local copy: my $save_TNS_ADMIN = $ENV{'TNS_ADMIN'}; die if not ok( $save_TNS_ADMIN ,'$TNS_ADMIN is defined' ); my $tmp_tns = cwd() . '/tmp_tns_admin' ; system( "rm -rf $tmp_tns" ) if -d $tmp_tns; mkdir $tmp_tns; system( "cp $save_TNS_ADMIN/*.* $tmp_tns/" ); open( TNSNAMES ,">>$tmp_tns/tnsnames.ora" ) or die "could not open $tmp_tns/tnsnames.org: $!\n" ; my $testdbfail = qq(testdbfail = (DESCRIPTION = (ADDRESS_LIST = (ADDRESS = (PROTOCOL = TCP)(HOST = $down_host)(PORT = 1521)) ) (CONNECT_DATA = (SERVICE_NAME = testdbfail) ) ) ); #ok... we have a local TNS_ADMIN directory $ENV{TNS_ADMIN} = $tmp_tns; print "redefining TNS_ADMIN=$tmp_tns\n" ; print "appending to $tmp_tns/tnsnames.ora:\n$testdbfail\n" ; print TNSNAMES $testdbfail; close TNSNAMES; use Sys::SigAction qw( set_sig_handler ); my $dbh; print "trying missing host test ($iterations iterations will be run)\n" ; for ( my $i = 1; $i < $iterations+1; $i++ ) { eval { my $code = sub { die "timed out on connect to database on missing host\n" ; }; #note that if you ask for safe, it will not work... my $h = set_sig_handler( 'ALRM' ,$code ,{ flags=>0 ,safe=>0 } ); eval { alarm(1); print "opening testdbfail (missing host test)\n" ; $dbh = DBI->connect("dbi:Oracle:testdbfail" ,"na" ,"na" ); alarm(0); print "connect failed!\n" if not $dbh; ok( 0 ,"after missing_host connect... how did we get here?\n" ); }; alarm(0); die $@ if $@; }; if ( $@ ) { ok( 1 ,"exception: $@" ); } print "completed iteration $i\n" ; } #iterate over this test print "after missing_host test\n" ; print "connecting to $dbn as $usr\n" ; $dbh = DBI->connect( "dbi:Oracle:$dbn" ,$usr ,$pwd ,{ RaiseError=>1 ,AutoCommit=>0 ,PrintError => 0 } ); ok( $dbh ,"connected" ); my $sql = qq{ BEGIN WHILE ( 1 > 0 ) LOOP NULL; END LOOP; END; }; print "execute timeout test... ($iterations iterations will be run)\n" ; print "using sql:\n$sql\n" ; for ( my $i = 1; $i < $iterations+1; $i++ ) { print "calling \$dbh->prepare()\n" ; my $sth = $dbh->prepare( $sql ); my $canceled = 0; eval { my $h = set_sig_handler( 'ALRM' ,sub { $canceled = 1; $sth->cancel(); #dont die (oracle spills its guts) } ,{ mask=>[ qw( INT ALRM ) ] ,safe => 0 } ); eval { my $timeout = 1; print "\ncalling execute with $timeout second timeout\n" ; alarm($timeout); $sth->execute(); alarm(0); ok( 0 ,"after execute of infinite statement (how did we get here?)\n" ); }; alarm(0); die $@ if $@; }; if ( $@ ) { print $@ if not $@ =~ m/DBD::Oracle/; ok( $canceled ,'execute timed out -- sighandler called' ); } else { ok( 0 ,"how come \$\@ was not set?" ); } print "completed iteration $i\n" ; } #for iterations... $dbh->rollback(); $dbh->disconnect(); exit; #end of test script =head1 AUTHOR Lincoln A Baxter =head1 COPYRIGHT Copyright (c) 2004-2009 by Lincoln A Baxter All rights reserved. This file may be distributed 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 perldoc Sys::SigAction =cut Sys-SigAction-0.20/README0000644000175000017500000000137112173014376013033 0ustar lablabSys/SigAction version 0.11 ========================== Sys::SigAction provides EASY access to POSIX::sigaction() for signal handling on systems the support sigaction(). perldoc Sys::SigAction for more information. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Test::More posix( sigactioni, ceil ) This module will use the follow module if present: Time::HiRes( ualarm) for fractional second timeouts. COPYRIGHT AND LICENCE 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, Sys-SigAction-0.20/lib/0000755000175000017500000000000012177571553012730 5ustar lablabSys-SigAction-0.20/lib/Sys/0000755000175000017500000000000012177571553013506 5ustar lablabSys-SigAction-0.20/lib/Sys/SigAction.pm0000644000175000017500000004552012177543640015726 0ustar lablab# # 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, 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 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 is not loadable or C does not work, then the factional part of the time value passed to C 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, and get the signal number from the name -- C. =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 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 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: Cconnect()> 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 to install the signal handler. With C, one gets control over both the signal mask, and the C 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 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 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 =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 =head 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. Sys-SigAction-0.20/t/0000755000175000017500000000000012177571553012425 5ustar lablabSys-SigAction-0.20/t/name.t0000644000175000017500000000123510512454201013510 0ustar lablab# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### use Test::More tests => 3; BEGIN { use_ok('Sys::SigAction') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. use strict; #use warnings; use Carp qw( carp cluck croak confess ); use Data::Dumper; use POSIX ':signal_h' ; use Sys::SigAction qw( sig_name sig_number ); ok( sig_name( SIGINT ) eq 'INT' ,'SIGINT => INT' ); ok( sig_name( 9 ) eq 'KILL' ,'9 => KILL' ); exit; Sys-SigAction-0.20/t/timeout.t0000644000175000017500000001020412177571326014273 0ustar lablab# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More; my $do_subsec = 0; #BEGIN { # use_ok('Sys::SigAction'); # if ( Sys::SigAction::have_hires() ) # { # eval "use Time::HiRes qw( time );"; # } #} ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. use strict; #use warnings; use Carp qw( carp cluck croak confess ); use Data::Dumper; use Sys::SigAction::Alarm; use Sys::SigAction qw( set_sig_handler timeout_call ); use POSIX qw( INT_MAX pause :signal_h ); use Config; ### identify platforms I don't think can be supported per the smoke testers #my $broken_hires_platforms = { # 'archname' => { ##poss 'amd64-midnightbsd-thread-multi' => 1 ##testing ,'i486-linux-gnu-thread-multi-64int' => 1 # } # ,'perlver' => { ##poss 'v5.16.2' => 1 ##testing ,'v5.14.2' => 1 # } #}; # # #my $broken_hires = ( # exists ( $broken_hires_platforms->{archname}->{$Config{archname}} ) # && exists ( $broken_hires_platforms->{perlver}->{$^V} ) # ); #$broken_hires = 1; #force broken path if ( Sys::SigAction::Alarm::hires_works() ) { $do_subsec = 1; eval "use Time::HiRes;"; plan tests => 19; } else { plan tests => 14; } my $num_args_seen; my $sum_args_seen; sub hash { die { hash=>1 }; } sub sleep_one { sleep 1; die "sleep_one"; } sub immediate { die "immediate"; } sub forever { pause; } sub forever_w_args { $num_args_seen = @_; $sum_args_seen += $_ for @_; forever(); } my $ret = 0; eval { $ret = timeout_call( 1, \&hash ); }; ok( (ref( $@ ) and exists($@->{'hash'})) ,'die with hash' ); ok( $ret == 0 ,'hash did not timeout' ); $ret = 0; eval { $ret = timeout_call( 1, \&immediate ); }; ok( (not ref($@) and $@ ),'immediate -- die with string' ); ok( $ret == 0 ,'immediate did not timeout' ); $ret = 0; eval { $ret = Sys::SigAction::timeout_call( 1, \&forever ); #print "forever timed out\n" if $ret; }; if ( $@ ) { print "why did forever throw exception:" .Dumper( $@ ); } ok( (not $@ ) ,'forever did NOT die' ); ok( $ret ,'forever timed out' ); foreach my $args ([1], [2, 3]) { $ret = 0; my $num_args_ok = @$args; my $sum_args_ok = 0; $sum_args_ok += $_ for @$args; $num_args_seen = $sum_args_seen = 0; eval { $ret = Sys::SigAction::timeout_call( 1, \&forever_w_args, @$args ); }; local $" = ', '; ok( (not $@ ) ,"forever_w_args(@$args) did NOT die" ); ok( $ret ,"forever_w_args(@$args) timed out" ); ok( $num_args_seen == $num_args_ok,"forever_w_args(@$args) got $num_args_seen args" ); ok( $sum_args_seen == $sum_args_ok,"forever_w_args(@$args) args sum is $sum_args_seen" ); } if ( not Sys::SigAction::Alarm::hires_works() ) { diag "\nTime::HiRes is not installed or Time::HiRes::ualarm() is broken\nFractional second timeout tests skipped\n" ; } else { #diag( "\nFractional second tests:\n" ); #5 more tests... $ret = 0; my $btime; my $etime; eval { $btime = Time::HiRes::time(); $ret = Sys::SigAction::timeout_call( 0.1, \&forever ); }; if ( $@ ) { print "hires: why did forever throw exception:" .Dumper( $@ ); } $etime = Time::HiRes::time(); ok( (not $@ ) ,'hires: forever did NOT die' ); ok( $ret ,'hires: forever timed out' ); my $delta = $etime - $btime; diag( "delta time was ".sprintf( "%.6f" ,$delta ).", timer was for 0.1 secconds" ); ok( ($delta < 0.8 ), "timeout in < 0.8 seconds" ); #diag( "Testing HiRes where msecs is greater than maxint (" .POSIX::INT_MAX().")" ); my $toobig = INT_MAX(); $toobig = ($toobig/1_000_000.0) + 1.1; $ret = 0; eval { $ret = timeout_call( $toobig, \&sleep_one ); }; ok( (not ref($@) and $@ ),"immediate -- die with string (toobig=$toobig)" ); ok( $ret == 0 ,"immediate did not timeout (with toobig=$toobig)" ); } exit; Sys-SigAction-0.20/t/safe.t0000644000175000017500000001107012175024230013506 0ustar lablab# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' #lab: this could be a clone of mask.t. The idea would be to turn on safe #signal handling and verify the same results. The problem is that it does #not appear to work. # ######################### use Test::More ; my $tests = 1; #BEGIN { use_ok('Sys::SigAction') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. use strict; #use warnings; use Carp qw( carp cluck croak confess ); use Data::Dumper; use POSIX ':signal_h' ; use Sys::SigAction qw( set_sig_handler sig_name sig_number ); #from mask.t: #see commends in mask.t for concept of this test... ##summary: the kills in sigHUP are masked, and execute only after #sigHUP finished without interuption my $hup = 0; my $int = 0; my $usr = 0; my $cnt = 1; sub sigHUP { ok( ($cnt++ == 1) ,'sigHUP called (1)' ); kill INT => $$; kill USR1 => $$; $hup++; sleep 1; ok( ($cnt++==2) ,'sig mask delayed INT and USR1(2)' ); } sub sigINT_1 { #since USR1 is delayed by mask of USR1 on this Signal handler # ok( ($cnt==3) ,"sigINT_1 called(3) failure: ($cnt!=3) this should have been delayed by mask until sigHUP finished" ); $cnt++; $int++; sleep 1; ok( ($cnt++==4) ,"sig mask delayed USR1 (signaled from sigHUP)(4)" ); } sub sigUSR_1 { ok( ($cnt==5) ,"sigUSR called (5) failure: ($cnt!=5) it should have been delayed by mask until sigHUP finished)" ); $cnt++; $usr++; } #end included functions from mask.t ... SKIP: { # if ($] <5.008) # { # plan skip_all => "using the safe attribute requires perl 5.8.2 or later"; # } if ( ($] <5.008002) ) { $tests += 3; plan tests => $tests; ok( 1, "NOTE: using the safe attribute requires perl 5.8.2 or later" ); eval { local $SIG{__WARN__} = sub { die $_[0]; }; my $h = set_sig_handler( sig_number(SIGALRM) ,sub { die "Timeout!"; }, { safe =>0 } ); }; #print STDERR "\ntest 2: \$\@ = '$@'\n"; ok( $@ eq '', "safe=>0 got no warning in \$\@ = '$@'" ); eval { local $SIG{__WARN__} = sub { die $_[0]; }; my $h = set_sig_handler( sig_number(SIGALRM) ,sub { die "Timeout!"; }, { safe =>1 } ); }; ok( $@ ne '' ,"safe=>1 expected warning in \$\@ = '$@'" ); eval { local $SIG{__WARN__} = sub { die $_[0]; }; my $h = set_sig_handler( sig_number(SIGALRM) ,sub { die "Timeout!"; } ); }; ok( $@ eq "", "safe not set: no warning in \$\@ = '$@'" ); } else # ($] >= 5.008002 ) { if ( ! $ENV{SAFE_T} ) #setting safe mode breaks masked signals { plan tests => $tests; print STDERR " NOTE: Setting safe=>1... with masked signals does not seem to work. The problem is that the masked signals are not masked when safe=>1. When safe=>0 they are. If you have an application for safe=>1 and can come up with a test that works in the context of this module's installation please send me a patch to safe.t that tests it. See the block below this one... which if executed would test safe mode with masked signals... it is a clone of part of mask.t that proves this is broken. Lincoln \n"; ok( 1, "skipping test of safe flag for now" ); } else { #including mask.t here testing with masked signals... $tests = 6; plan tests => $tests; #testing again with safe on #set_sig_handler( 'HUP' ,\&sigHUP ,{ flags => SA_RESTART, mask=>[ qw( INT USR1 ) ] , safe=>1 } ); #set_sig_handler( 'INT' ,\&sigINT_1 ,{ flags => SA_RESTART, mask=>[ qw( USR1 )] ,safe=>1 } ); #set_sig_handler( 'USR1' ,\&sigUSR_1 ,{ flags => SA_RESTART, safe=>1 } ); set_sig_handler( 'HUP' ,\&sigHUP ,{ flags => SA_RESTART, mask=>[ qw( INT USR1 ) ] , safe=>1 } ); set_sig_handler( 'INT' ,\&sigINT_1 ,{ flags => SA_RESTART, mask=>[ qw( USR1 )] ,safe=>1 } ); set_sig_handler( 'USR1' ,\&sigUSR_1 ,{ flags => SA_RESTART, safe=>1 } ); kill HUP => $$; ok( ( $cnt++==6 ), "reached 6th test after first kill" ); #lab ok( ($hup==1 ), "hup=1 ($hup)" ); #lab ok( ($int==1 ), "int=1 ($int)" ); #lab ok( ($usr==1 ), "usr=1 ($usr)" ); } } } #ok( $int ,'sigINT called' ); #ok( $usr ,"sigUSR called $usr" ); exit; Sys-SigAction-0.20/t/number.t0000644000175000017500000000116210002157403014055 0ustar lablab# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### use Test::More tests => 3; BEGIN { use_ok('Sys::SigAction') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. use strict; #use warnings; use POSIX ':signal_h' ; use Sys::SigAction qw( sig_name sig_number ); ok( sig_number( 'INT' ) == SIGINT ,'INT => SIGINT' ); ok( sig_number( 'KILL' ) eq SIGKILL ,'KILL => SIGKILL' ); exit; Sys-SigAction-0.20/t/mask.t0000644000175000017500000001047412175024631013537 0ustar lablab# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' #lab: fixed that setting of SAFE in POSIX::sigaction, and the result #is that setting it the test causes the test to break... so it is now #commented out here. ######################### use Test::More ; my $tests = 14; #BEGIN { use_ok('Sys::SigAction') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. use strict; #use warnings; use Config; use Carp qw( carp cluck croak confess ); use Data::Dumper; use POSIX ':signal_h' ; use Sys::SigAction qw( set_sig_handler sig_name sig_number ); ### identify platforms I don't think can be supported per the smoke testers my $mask_broken_platforms = { 'archname' => { 'i686-cygwin-thread-multi-64int' => 1 } ,'perlver' => { 'v5.10.1' => 1 } }; my $on_broken_platform = ( exists ( $mask_broken_platforms->{'archname'}->{$Config{'archname'}} ) && exists ( $mask_broken_platforms->{'perlver'}->{$^V} ) ); my $hup = 0; my $int = 0; my $usr = 0; my $cnt = 1; sub sigHUP { ok( ($cnt++ == 1) ,'sigHUP called (1)' ); kill INT => $$; kill USR1 => $$; $hup++; sleep 1; ok( ($cnt++==2) ,'sig mask delayed INT and USR1(2)' ); } sub sigINT_1 { #since USR1 is delayed by mask of USR1 on this Signal handler # ok( ($cnt==3) ,"sigINT_1 called(3) failure: ($cnt!=3) this should have been delayed by mask until sigHUP finished" ); $cnt++; $int++; sleep 1; ok( ($cnt++==4) ,"sig mask delayed USR1 (signaled from sigHUP)(4)" ); } sub sigUSR_1 { ok( ($cnt==5) ,"sigUSR called (5) failure: ($cnt!=5) it should have been delayed by mask until sigHUP finished)" ); $cnt++; $usr++; } sub sigINT_2 #masks USR1 { ok( ($cnt++==8) ,'sigINT_2 called (8)' ); kill USR1=>$$; sleep 1; ok( ($cnt++==9) ,'sigINT_2 exiting (9)' ); } sub sigHUP_2 { #no mask ok( ($cnt++ == 7) ,'sigHUP_2 called' ); kill INT => $$; sleep 1; ok( ($cnt++==11 ) ,'sigHUP_2 ending' ); } sub sigUSR_2 { #no mask ok( ($cnt++==10) ,'sigUSR2 called (10)' ); $usr++; } # A test that sets a signal mask, then in a signal handler # raises the masked signal. The test succeeds when the mask prevents # the new signal handler from being called until the currently executing # signal handler exits. #plan is a follows: #sigHUP raises INT and USR1 then sleeps and is ok if it gets to the bottom # the mask is supposed to delay the execution of sig handlers for INT USR1 # sigHUP sleeps to prove it (this is test 2,3) #when sigHUP exits # sigINT_1 is called because sigUSR is masked... test 4 # sigINT_1 sleeps to prove it (test 5) #when sigINT_1 exits # sigUSR_1 is called .. it just prints that it has been called (test 6) # #then we do the same thing for new sig handers on INT and USR1 # SKIP: { plan skip_all => "perl $^V on $Config{'archname'} does not appear to mask signals correctly." if ( $on_broken_platform ); #plan skip_all => "masking signals is broken on at least some versions of cygwin" if ( $^O =~ /cygwin/ ); plan skip_all => "requires perl 5.8.0 or later" if ( $] < 5.008 ); plan tests => $tests; # print STDERR " # NOTE: Setting safe=>1... with masked signals... does not seem to work # the masked signals are not masked; when safe=>0 then it does... # Not testing safe=>1 for now\n"; set_sig_handler( 'HUP' ,\&sigHUP ,{ mask=>[ qw( INT USR1 ) ] } ); #,safe=>0 } ); #set_sig_handler( 'HUP' ,\&sigHUP ,{ mask=>[ qw( INT USR1 ) ] ,safe=>undef } ); set_sig_handler( 'INT' ,\&sigINT_1 ,{ mask=>[ qw( USR1 )] } ); #,safe=>0 } ); #set_sig_handler( 'INT' ,\&sigINT_1 ); #,{ safe=>0 } ); set_sig_handler( 'USR1' ,\&sigUSR_1 ); #,{ safe=>0 } ); kill HUP => $$; ok( ( $cnt++==6 ), "reach 6th test after first kill" ); set_sig_handler( 'INT' ,\&sigINT_2 ,{ mask=>[ qw( USR1 )] } ); set_sig_handler( 'HUP' ,\&sigHUP_2 ,{ mask=>[ qw( )] } ); set_sig_handler( 'USR1' ,\&sigUSR_2 ); #,{ safe=>0 } ); kill HUP => $$; ok( ($hup==1 ), "hup=1 ($hup)" ); ok( ($int==1 ), "int=1 ($int)" ); ok( ($usr==2 ), "usr=2 ($usr)" ); } #ok( $int ,'sigINT called' ); #ok( $usr ,"sigUSR called $usr" ); exit; Sys-SigAction-0.20/t/nested.t0000644000175000017500000000366711103136257014072 0ustar lablab# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More; # tests => 5; #BEGIN { use_ok('Sys::SigAction') }; use Sys::SigAction; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. use strict; #use warnings; use Carp qw( carp cluck croak confess ); use Data::Dumper; use Sys::SigAction qw( set_sig_handler ); use POSIX ':signal_h' ; my @levels = ( 0 ,0 ,0 ,0 ); sub sighandler { print "level 1\n" ; $levels[1] = 2; } #plan is a follows: # # A test that sets signal handlers in nested blocks, and tests that # at each level of nesting, the signal handler at the next level up # is still valid (for the same signal). The idea is that the scope of # the block prevents the next level up signal handle from being overwritten. # #global... should be good at the end... my $tests = 4; plan tests => $tests; my $ctx0 = set_sig_handler( SIGALRM ,sub { print "level 0\n" ; $levels[0] = 1; } ); eval { my $ctx1 = set_sig_handler( 'ALRM' ,'sighandler' ); #print Dumper( $ctx1 ); if ( 1 ) { eval { my $ctx2 = set_sig_handler( SIGALRM ,sub { print "level 2\n"; $levels[2] = 3; } ); eval { my $ctx3 = set_sig_handler( 'ALRM' ,sub { print "level 3\n"; $levels[3] = 4; } ); kill ALRM => $$; #undef $ctx3; }; if ($@) { warn "handler died: $@\n"; } kill ALRM => $$; }; if ( $@ ) { warn "error: $@\n"; } } kill ALRM => $$; }; if ( $@ ) { warn "error: $@\n"; } eval { kill ALRM => $$; }; if ($@ ) { warn "error :$@\n"; } my $i = 0; foreach my $level ( @levels ) { ok( $level ,"level $i is not 0" ); print "level $i = $level\n" ; $i++; } exit; Sys-SigAction-0.20/META.yml0000644000175000017500000000113012177571553013426 0ustar lablab--- #YAML:1.0 name: Sys-SigAction version: 0.20 abstract: Perl extension for Consistent Signal Handling author: - Lincoln A. Baxter license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: POSIX: 0 Test::More: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Sys-SigAction-0.20/Makefile.PL0000644000175000017500000001220212177571301014120 0ustar lablab# See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. use 5.005; use ExtUtils::MakeMaker; # add a number of tests to stop the smoke testers from reporting Failed # in unsupported environments # print "Checking for Microsoft Windows... (not supported)\n"; if ( $^O =~ /MSWin32/ ) { die q{ OS unsupported Sys::SigAction is not Supported on on $^O operating systems if you can make all or most of the tests work on this OS, then please send patches to me, and I will consider them for a new release that supports $^O. Note that smoke testers have had successful results in a Cygwin environment however. So if you want to write scripts using signals on a Win32 environment consider Cygwin Bash. Lincoln }; } print "Checking for multi-threaded Perl... (warning)\n"; use Config; eval "use threads"; #belt and suspenders.... if ( ! $@ || $Config{usethreads} || $Config{useithreads} || $Config{use5005threads} ) { warn q{ This perl has multithread support enabled, this is not a problem for single threaded perl applications. Please see "MULTITHREAD PERL in the Sys::SigAction POD for more information Lincoln }; } print "Checking support for signals... (required)\n"; if ( ! defined $Config{sig_name} ) { die q{ Signals are not supported in this OS or perl version. } } #is sigaction enabled? print "Checking support for POSIX::sigaction... (required)\n"; if ( ( $] >= 5.008 ) && ! ( $Config{useposix} && $Config{d_sigaction} ) ) { die q{ This perl is not supported. Perl must be built with 'useposix' and 'sigaction' defined. }; } print "Checking for armv5tejl... (not supported)\n"; #belt and suspenders.... if ( $Config{archname} =~ m/armv5tejl/ ) { die q{ Sys::SigAction is not supported on armv5tejl systems. I have communicated with the smoke tester on this OS, and we believe that the base perl implementation of POSIX:sigaction is probably the root cause. if you want to use this module anyway, or work on getting it supported by fixing the perl port, you can uncomment out this section of Makefile.PL to build Sys::SigAction. }; } print "Checking for cygwin... (masking signals is broken on some versions at least)\n"; if ( $^O =~ /cygwin/ ) { warn q( Smoke testers have discovered that t/mask.t fails on at least some verions cygwin. Specific versions of the os and perl and now protected... but others may be found. On this platforms masking signals probably does not work. See the hash reference \$broken_platforms for platforms known to be broken. ); } my $SAAD = "lib/Sys/SigAction/" ; my $SAA = "$SAAD/Alarm.pm" ; print "Writing $SAA\n" ; mkdir $SAAD if ( not -d $SAAD ); open( SAH, ">$SAA" ); print SAH q( package Sys::SigAction::Alarm; require 5.005; use strict; #use warnings; use vars qw( @ISA @EXPORT_OK ); require Exporter; @ISA = qw( Exporter ); @EXPORT_OK = qw( ssa_alarm ); my $have_hires = scalar eval 'use Time::HiRes; Time::HiRes::ualarm(0); 1;'; use POSIX qw( INT_MAX ceil ) ; my $hrworks; sub ssa_alarm($) { my $secs = shift; #print print "secs=$secs\n"; if ( $hrworks and ($secs le (INT_MAX()/1_000_000.0) ) ) { Time::HiRes::ualarm( $secs * 1_000_000 ); } else { alarm( ceil( $secs ) ); } } sub hires_works { return $hrworks; }; #test support ); print "Looking for Time::HiRes with a working ualarm()... \n" ; use constant HR => eval 'use Time::HiRes; Time::HiRes::ualarm(0); 1;' ; sub forever { pause(); } sub handler { die "TIMEDOUT"; } my $et, $st; my $hr_works = 0; if ( not HR ) { print q( Time::HiRes is not installed. High resolution timeouts disabled. ); } else { print "Testing Time::HiRes::ualarm()\n" ; $SIG{'ALRM'} = \&handler; eval { $st = Time::HiRes::time(); eval { Time::HiRes::ualarm( 0.1 * 1_000_000 ); forever(); }; Time::HiRes::ualarm( 0 ); $et = Time::HiRes::time(); #print "outside forever eval\n" ; }; my $delta = $et - $st; if ( $delta < 0.8 ) { print q( Time::HiRes::ualarm() exists and works. High resolution timeouts enabled." ); $hr_works = 1; } else { warn q( Time::HiRes exists on this platform but Time::HiRes::ualarm appears to be broken. High resolution timeouts disabled. ); } } print SAH '$hrworks = '."$hr_works; 1;\n" ; close( SAH ); print "\nWrote $SAA\n" ; if ( not $hr_works ) { warn q( Fractional seconds in timeout_call() may be used but will be raised to the next higher integer value with POSIX::ceil(). ); } #ok... enough defensiveness... my $args = { 'NAME' => 'Sys::SigAction', 'VERSION_FROM' => 'lib/Sys/SigAction.pm', # finds $VERSION 'PREREQ_PM' => { 'Test::More' => 0 ,POSIX => 0 }, # e.g., Module::Name => 1.1 'ABSTRACT_FROM' => 'lib/Sys/SigAction.pm', # retrieve abstract from module 'AUTHOR' => 'Lincoln A. Baxter ' }; print "MakeMaker version = $ExtUtils::MakeMaker::VERSION\n"; if ($ExtUtils::MakeMaker::VERSION >= 6.3002 ) { $args->{LICENSE} = 'perl'; } WriteMakefile( %$args ); Sys-SigAction-0.20/Changes0000644000175000017500000002226112177571273013457 0ustar lablab=cut =head1 NAME Sys::SigAction::Changes - List of significant changes =head1 CHANGES Revision history for Sys::SigAction. =head2 Changes in Sys::SigAction 0.20 4 Aug 2013 Even if C exists, it may not necessarily work. (There were way too many broken smoke tests with were the result of this. One reason for this may bave been that the test was looking for too small an interval of sub-second timeouts. On busy systems, this may have been causing tests to fail. Got rid of the attempt at tracking broken environments in timeout.t (the hash structure mentioned in the previous change. The sub-second timer tests now set a timeout at 0.1 seconds, and check for a delta time the is less then 0.8 seconds. Proving that they completed in under 1 second, but give a wide range of execution time to account for busy systems. Also Makefile.PL now looks for C, and tests it. If it works, high resolution timeouts are enabled in Sys Makefile.PL reports what it finds, and t/timeout.t reports when high resolution tests are disabled, but timeout.t should not fail because of this... it will just run fewer tests. =head2 Changes in Sys::SigAction 0.19 27 Jul 2013 Change sig_alarm() to use HiRes::ualarm() instead of HiRes::alarm(). Hoping to fix hires test failures on some platforms. Build a hash structure in timeout.t to disable the HiRes tests on certain platforms where these functions may to be consistently broken, but disable them for at least another round, hoping that the change to using HiRes::ualarm() solves the problem. Also, restructure timeout.t to hardcode the number of tests run. Apparently Test::More on perl 5.8.x insisteds on getting the plan before ANY tests are run. Build similar structure in mask.t to disable the test on certain platforms were signal masking appears to be broken. Currently this is set to my $mask_broken_platforms = { 'archname' => { 'i686-cygwin-thread-multi-64int' => 1 } ,'perlver' => { 'v5.10.1' => 1 } }; Update Makefile.PL to note the fact the HiRes timeouts may broken on some platforms. =head2 Changes in Sys::SigAction 0.18 24 Jul 2013 Fix "bareword" error on some platforms at least, by explicitly importing INT_MAX from POSIX module. Fix Changes file which listed verson 0.16 twice when it should have list version 0.17 for the more recent changes. =head2 Changes in Sys::SigAction 0.17 22 Jul 2013 Fix timeout.t to use POSIX::pause() instead of select(), which was used to optimized the while ( 1 ) loop in the forever function. This caused failures on some platforms. pause() is right solution -- thanks (again) to Carsten Gaebler and for the suggestion for handling the Time::HiRes request. More double eval documentation cleanup that had not been previously caught in the POD. (bug #79130). When Time::HiRes is present, allow for long timeouts longer than the POSIX::INT_MAX microseconds when Time::HiRes is present. Just call call alarm() instead of ualarm() in the case where input argument would result in a msecs value in an argument to ualarm which is larger than POSIX::INT_MAX (and, of course, add a test for this in timeout.t). (bug/enhancement request #75784) Fix typos in dbd-oracle-timeout.POD (bug #87141). It appears that the DBD:oracle module may now have internal handling for this problem (DBD::oracle not longer references Sys::SigAction). =head2 Changes in Sys::SigAction 0.16 21 Jul 2013 Thanks to excellent patches from Carsten Gaebler (contact me if you want to contact him), timeout_call() now supports passing an array of arguments which it will pass to the code it executes. Minor tweak to POD. =head2 Changes in Sys::SigAction 0.15 1 Jul 2011 Clean up POD. Close bug #69057. Other minor tweaks to POD. =head2 Changes in Sys::SigAction 0.13 23 Jun 2011 No functional changes. Fix for test timeout.t. Fix strict undefined symbol error in timeout.t, when Time::HiRes is not present. Not sure if constant pragma will exist in all supported perl versions, so, we just commented out the use strict in this test. Print warning when Time::HiRes not found in Makefile.PL =head2 Changes in Sys::SigAction 0.12 20 Jun 2011 Conditionally add 'LICENSE' => 'perl' to WriteMakefile() call if $ExtUtils::MakeMaker::VERSION >= 6.3002. Added support for timeout_call() in fractional seconds expressed as a floating point number. If Time::HiRes is not loadable, then the timeout value is raised to the next high integer value with the POSIX:ceil() funtion. Added sig_alarm(), which timeout_call uses. This is drop in replacement for alarm(). If Time::HiRes is not loadable, then the seconds argument is raised to the next high integer value with the POSIX:ceil() funtion. Update sample code to use double evals in response https://rt.cpan.org/Public/Bug/Display.html?id=50628 The bug author wrote: Suppose the eval dies for some reason unrelated to the signal handling just before the alarm expires, and then the code exits the eval, and then the alarm expires before the final alarm(0) can be called. Now 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. Make the same change in timeout_call(). The change traps the remote possibility that an alarm signal could arrive between the time code dies (for some unrelated reason) and the final eval is called or called. =head2 Changes in Sys::SigAction 0.11 31 Jan 2009 Remove Restriction in License which required permission to include in CDROM media for commercial distribution. License is now Straight GPL or Artistic as Perl is. Fix safe attribute for perl >= 5.8.2, but applying patch in (duplicate) bugs: http://rt.cpan.org/Ticket/Display.html?id=39599 http://rt.cpan.org/Ticket/Display.html?id=39946 Test by cloning mask.t into safe.t in the block for perl => 5.008002 and test setting safe attribute. Sadly, using both masked signals and safe=>1 at the same time, is still broken. Add checks for unsupported configurations in Makefile.PL to (hopefully) suppress the Smoke test failures for those environments. Update documentation. Lincoln =head2 Changes in Sys::SigAction 0.10 24 Oct 2006 Documentation cleanup, thanks to Tim Maher. Lincoln =head2 Changes in Sys::SigAction 0.09 17 Oct 2006 Francesco has pointed out that I still have a special case of safe=>0 broken for perl 5.8.0. The perl 5.8.1 build I tested with (I could not find 5.8.0) it turns out has .../lib/5.8.1/auto/POSIX/SigAction/safe.al, my previous tests works. This version of Sys::SigAction now as a test of these subtleties in t/safe.t, those still no real test of safe=>1 for perls >= 5.8.2 Lincoln =head2 Changes in Sys::SigAction 0.08 11 Oct 2006 Add extra protection to test of $attrs->(safe} when the perl version is between 5.8 and 5.8.2, thanks to Francesco Duranti. Now test for it being defined before testing it's value. It would be a pretty bizarre case for that to happen, but... belt and suspenders... is 'safe'. Fix warning in safe.t which referred to attrs.t (old test name) which was renamed to mask.t, to refer to mask.t. Lincoln =head2 Changes in Sys::SigAction 0.07 09 Oct 2006 Version 0.06 broke in perl < 5.8.2... (who uses that any more!!!) Well someone does... at least on RedHat... I did (do) claim backwards compatibility... So I fixed it right this time, by checking the perl version before called the safe accessor on the POSIX::SigAction object. Still no good test for safe mode... be prepared to send me a test if you think safe signal handling is broken... for sure I could not get it to work the way I think it should with with deferred signals. Lincoln =head2 Changes in Sys::SigAction 0.06 25 June 2006 Fix setting of SAFE flag in POSIX::sigaction. In response to CPAN bug: http://rt.cpan.org/Ticket/Display.html?id=19916 Thanks to Steve Purk?, for point this out. This required NOT setting safe=>1 (changing to to safe=>0) in t/attrs.t and the the dbd-oracle test script. A new test for safe=>1 needs to be developed, which explicitly tests deferred signal handling. I would welcome such a contribution. Lincoln A Baxter =head2 Changes in Sys::SigAction 0.05 24 July 2004 Fix typo in POD for mask => thanks to Henri Asseily This was apparently never uploaded. :-( Lincoln A Baxter =head2 Changes in Sys::SigAction 0.04 7 April 2004 Modify forever() in timeout.t so just loop instead of trying to read from STDIN, which apparently does not block or immediately returns an error on some platforms or test environments Lincoln A Baxter ck =head2 Changes in Sys::SigAction 0.03 4 April 2004 Skip attrs.t test if perl version < 5.8.2 (rt.cpan.org ticket #5948) Rename dbd-oracle-timout.PL -> dbd-oracle-timeout.POD =head2 Changes in Sys::SigAction 0.02 3 February 2004 Comment out 'use warnings' for $] < 5.006 Suppress undefined warning in destructor for $] < 5.008 Documentation expansion and cleanup Add dbd-oracle-timeout.PL Lincoln A Baxter =head2 Original version: Sys::SigAction 0.01 17 January 2004 original version; created by h2xs 1.22 with options: --compat-version=5.5.0 -X --name=Sys::SigAction \ --use-new-tests --skip-warnings --version=0.01 Lincoln A Baxter =cut Sys-SigAction-0.20/MANIFEST0000644000175000017500000000027612177545031013310 0ustar lablabChanges Makefile.PL META.yml Module meta-data (added by MakeMaker) README MANIFEST t/mask.t t/safe.t t/name.t t/nested.t t/number.t t/timeout.t dbd-oracle-timeout.POD lib/Sys/SigAction.pm