r76398 - in /branches/upstream/libsys-sigaction-perl/current: Changes META.yml Makefile.PL dbd-oracle-timeout.POD lib/Sys/SigAction.pm t/timeout.t

mxey-guest at users.alioth.debian.org mxey-guest at users.alioth.debian.org
Thu Jun 23 21:04:21 UTC 2011


Author: mxey-guest
Date: Thu Jun 23 21:04:11 2011
New Revision: 76398

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=76398
Log:
[svn-upgrade] new version libsys-sigaction-perl (0.13)

Modified:
    branches/upstream/libsys-sigaction-perl/current/Changes
    branches/upstream/libsys-sigaction-perl/current/META.yml
    branches/upstream/libsys-sigaction-perl/current/Makefile.PL
    branches/upstream/libsys-sigaction-perl/current/dbd-oracle-timeout.POD
    branches/upstream/libsys-sigaction-perl/current/lib/Sys/SigAction.pm
    branches/upstream/libsys-sigaction-perl/current/t/timeout.t

Modified: branches/upstream/libsys-sigaction-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsys-sigaction-perl/current/Changes?rev=76398&op=diff
==============================================================================
--- branches/upstream/libsys-sigaction-perl/current/Changes (original)
+++ branches/upstream/libsys-sigaction-perl/current/Changes Thu Jun 23 21:04:11 2011
@@ -7,6 +7,48 @@
 =head1 CHANGES
 
 Revision history for Sys::SigAction.
+
+=head2 Changes in Sys::SigAction 0.12  22 Jun 2011
+
+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
 
@@ -109,7 +151,7 @@
 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)

Modified: branches/upstream/libsys-sigaction-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsys-sigaction-perl/current/META.yml?rev=76398&op=diff
==============================================================================
--- branches/upstream/libsys-sigaction-perl/current/META.yml (original)
+++ branches/upstream/libsys-sigaction-perl/current/META.yml Thu Jun 23 21:04:11 2011
@@ -1,12 +1,23 @@
-# http://module-build.sourceforge.net/META-spec.html
-#XXXXXXX This is a prototype!!!  It will change in the future!!! XXXXX#
-name:         Sys-SigAction
-version:      0.11
-version_from: lib/Sys/SigAction.pm
-installdirs:  site
+--- #YAML:1.0
+name:               Sys-SigAction
+version:            0.13
+abstract:           Perl extension for Consistent Signal Handling
+author:
+    - Lincoln A. Baxter <lab-at-lincolnbaxter-dot-com>
+license:            perl
+distribution_type:  module
+configure_requires:
+    ExtUtils::MakeMaker:  0
+build_requires:
+    ExtUtils::MakeMaker:  0
 requires:
-    POSIX:                         0
-    Test::More:                    0
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.30
+    POSIX:       0
+    Test::More:  0
+no_index:
+    directory:
+        - t
+        - inc
+generated_by:       ExtUtils::MakeMaker version 6.55_02
+meta-spec:
+    url:      http://module-build.sourceforge.net/META-spec-v1.4.html
+    version:  1.4

Modified: branches/upstream/libsys-sigaction-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsys-sigaction-perl/current/Makefile.PL?rev=76398&op=diff
==============================================================================
--- branches/upstream/libsys-sigaction-perl/current/Makefile.PL (original)
+++ branches/upstream/libsys-sigaction-perl/current/Makefile.PL Thu Jun 23 21:04:11 2011
@@ -34,16 +34,17 @@
    Using Signals in a multi-thread perl application is unsupported 
    by Sys::SigAction.
 
-   Sys::SigAction is not Supported on multi-threaded perls.
-
    Read the following from perldoc perlthrtut:
 
-      ...mixing signals and threads should not be attempted.  
-      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).
+      ...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.
+      
 
-   You are on your own...
+   You are on your own if we use this module in a multi threaded application
 
    Lincoln
 
@@ -85,19 +86,38 @@
    it supported by fixing the perl port, you can uncomment out
    this section of Makefile.PL to build Sys::SigAction.
 
-   Lincoln
    };
 }
 
+print "Checking for Time::HiRes (support for fractional seconds in timeouts)\n";
+eval "use Time::HiRes qw( ualarm )";
+if ( $@ ) {
+   warn q(
+   
+   Time::HiRes is not available.  Fractional seconds in timeout_call()
+   will be raised to the next high integer value with POSIX::ceil().
+   
+   );
+}
+
+
+
 #ok... enough defensiveness... 
-WriteMakefile(
+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 <lab-at-lincolnbaxter-dot-com>' 
-);
+    'ABSTRACT_FROM' => 'lib/Sys/SigAction.pm', # retrieve abstract from module
+    'AUTHOR'     => 'Lincoln A. Baxter <lab-at-lincolnbaxter-dot-com>' 
+};
 
+print "MakeMaker version = $ExtUtils::MakeMaker::VERSION\n";
+if ($ExtUtils::MakeMaker::VERSION >= 6.3002 ) {
+   $args->{LICENSE} = 'perl';
+}
+
+WriteMakefile( %$args );
+

Modified: branches/upstream/libsys-sigaction-perl/current/dbd-oracle-timeout.POD
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsys-sigaction-perl/current/dbd-oracle-timeout.POD?rev=76398&op=diff
==============================================================================
--- branches/upstream/libsys-sigaction-perl/current/dbd-oracle-timeout.POD (original)
+++ branches/upstream/libsys-sigaction-perl/current/dbd-oracle-timeout.POD Thu Jun 23 21:04:11 2011
@@ -72,11 +72,14 @@
 
    eval {
       local $SIG{ALRM} = sub { die "open timed out"; };
-      alarm(2); #implement 2 second time out
-      $dbh = DBI->connect("dbi:Oracle:$dbn" ... );
+      eval {
+         alarm(2); #implement 2 second time out
+         $dbh = DBI->connect("dbi:Oracle:$dbn" ... );
+         alarm(0);
+      };
       alarm(0);
+      die $@ if $@;
    };
-   alarm(0);
    if ( $@ ) { print "connection to $dbn timed out\n" ; }
 
 Because C<$SIG{ALRM}> has been 'localized', this code restores the 
@@ -93,17 +96,34 @@
 
    eval {
       local $SIG{ALRM} = sub { $sth->cancel(); };
-      alarm(2); #implement 2 second time out
-      $sth->execute( ... );
+      eval {
+         alarm(2); #implement 2 second time out
+         $sth->execute( ... );
+         alarm(0);
+      };
       alarm(0);
+      die $@ if $@;
    };
-   alarm(0);
    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 sames here have been adjusted to execute the code to be
+timed out in an inner eval to correct for this problem.
 
 =head2 The Problem
 
@@ -182,19 +202,22 @@
 
    use POSIX ':signal_h';
 
-   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" ... );
+      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 $@;
    };
-   alarm(0);
-   sigaction( 'ALRM' ,$oldaction ); #restore original signal handler
    if ( $@ ) ....
 
 This is not a pretty replacement for what was a single line of
@@ -221,11 +244,14 @@
 
    eval {
       my $h = set_sig_handler( 'ALRM' ,sub { die "connect failed" ; } );
-      alarm(2); #implement 2 second time out
-      $dbh = DBI->connect("dbi:Oracle:$dbn" ... );
+      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
-   alarm(0);
    if ( $@ ) ....
 
 And the nice thing about using C<Sys::SigAction>, is that it works with
@@ -335,14 +361,17 @@
          };
          #note that if you ask for safe, it will not work...
          my $h = set_sig_handler( 'ALRM' ,$code ,{ flags=>0 ,safe=>0 } ); 
-         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);
+         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: $@" );
@@ -382,14 +411,17 @@
                                         }
                                  ,{ mask=>[ qw( INT ALRM ) ] ,safe => 0 } 
                                  );
-         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);
+         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/;

Modified: branches/upstream/libsys-sigaction-perl/current/lib/Sys/SigAction.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsys-sigaction-perl/current/lib/Sys/SigAction.pm?rev=76398&op=diff
==============================================================================
--- branches/upstream/libsys-sigaction-perl/current/lib/Sys/SigAction.pm (original)
+++ branches/upstream/libsys-sigaction-perl/current/lib/Sys/SigAction.pm Thu Jun 23 21:04:11 2011
@@ -8,15 +8,45 @@
 require 5.005;
 use strict;
 #use warnings;
-use POSIX ':signal_h' ;
+use POSIX qw( :signal_h ceil ) ;
 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 ualarm if Time::HiRes
+#is load able or alarm with the ciel of the value passed if
+#Time::HiRes is not loadable. 
+#timeout_call uses sig_alarm()
+my $have_hires = 1; 
+{
+   eval "use Time::HiRes qw( ualarm )";
+   if ( $@ ) {
+      $have_hires = 0;
+   }
+}
+sub have_hires() { return $have_hires; }; #test support
+
+sub sig_alarm #replacement for alarm, takes factional seconds in floating point format
+{
+   my ( $secs ) = @_;
+   #print  print "secs=$secs\n";
+   if ( $have_hires )
+   {
+      $secs = $secs * 1000000.0;
+      #print "have hires: secs modified to $secs\n";
+      ualarm( $secs );
+   }
+   else
+   {
+      alarm( ceil( $secs ) );
+   }
+}
+
 #use Data::Dumper;
 
 @ISA = qw( Exporter );
- at EXPORT_OK = qw( set_sig_handler timeout_call sig_name sig_number );
-$VERSION = '0.11';
+ at EXPORT_OK = qw( set_sig_handler timeout_call sig_name sig_number sig_alarm );
+$VERSION = '0.13';
 
 use Config;
 my %signame = ();
@@ -142,11 +172,15 @@
    eval {
       #lab-20060625 unecessary: my $h = sub { $timed_out = 1; die TIMEDOUT; };
       my $sa = set_sig_handler( SIGALRM ,sub { $timed_out = 1; die TIMEDOUT; } );
-      alarm( $timeout );
-      &$code; 
-      alarm(0);
+      eval {
+         #print "timeout=$timeout\n" ;
+         sig_alarm( $timeout );
+         &$code; 
+         sig_alarm(0);
+      };
+      sig_alarm(0);
+      die $@ if $@;
    };
-   alarm(0);
    if ($@)
    {
       #print "$@\n" ;
@@ -196,11 +230,14 @@
    use Sys::SigAction qw( set_sig_handler );
    eval {
       my $h = set_sig_handler( 'ALRM' ,\&mysubname ,{ mask=>[ 'ALRM' ] ,safe=>1 } );
-      alarm(2)
-      ... do something you want to timeout
-      alarm(0);
+      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
-   alarm(0); 
    if ( $@ ) ...
 
 or
@@ -209,10 +246,14 @@
    my $alarm = 0;
    eval {
       my $h = Sys::SigAction::set_sig_handler( 'ALRM' ,sub { $alarm = 1; } );
-      alarm(2)
-      ... do something you want to timeout
-      alarm(0);
-   };
+      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
    alarm(0); 
    if ( $@ or $alarm ) ...
 
@@ -231,6 +272,15 @@
       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
@@ -239,7 +289,10 @@
 
 Also implemented is C<timeout_call()> which takes a timeout value and
 a code reference, and executes the code reference wrapped with an
-alarm timeout.
+alarm timeout. timeout_call accepts seconds in floating point format,
+so you can time out call with a resolution of 0.000001 seconds (assumes 
+Time::HiRes is loadable.
+ 
 
 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
@@ -282,7 +335,7 @@
 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,
+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 interupted
 with control-C, even when the intended timeout is only seconds). 
@@ -298,6 +351,21 @@
    };
    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.
@@ -355,6 +423,21 @@
 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() 
@@ -398,7 +481,12 @@
 
 Given a code reference, and a timeout value (in seconds), timeout()
 will (in an eval) setup a signal handler for SIGALRM (which will die),
-set an alarm clock, and execute the code reference.
+set an alarm clock, and execute the code reference. $time (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 Time:HiRes is not available then factional
+second values less than 1.0 are tranparently converted to 1.
 
 If the alarm goes off the code will be interupted.  The alarm is
 canceled if the code returns before the alarm is fired.  The routine
@@ -407,6 +495,21 @@
 
 The original signal handler is restored, prior to returning to the caller.
 
+If HiRes is not loadable, Sys::SigAction will do the right thing
+and convert 
+
+=head2 sig_alarm()
+
+   $seconds 
+
+sig_alarm() is a drop in replacment for the standard alarm() function.
+$seconds 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 $seconds with values less than 
+1.0 will be converted to 1 second.
+
 =head2 sig_name()
 
 Return the signal name (string) from a signal number.

Modified: branches/upstream/libsys-sigaction-perl/current/t/timeout.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libsys-sigaction-perl/current/t/timeout.t?rev=76398&op=diff
==============================================================================
--- branches/upstream/libsys-sigaction-perl/current/t/timeout.t (original)
+++ branches/upstream/libsys-sigaction-perl/current/t/timeout.t Thu Jun 23 21:04:11 2011
@@ -5,15 +5,22 @@
 
 # change 'tests => 1' to 'tests => last_test_to_print';
 
-use Test::More tests => 7;
-BEGIN { use_ok('Sys::SigAction') };
-
+use Test::More;
+BEGIN { 
+   use_ok('Sys::SigAction'); 
+   if ( Sys::SigAction::have_hires() ) 
+   {
+      eval "use Time::HiRes qw( clock_gettime CLOCK_REALTIME ); ";
+   } else {
+      eval "use constant CLOCK_REALTIME => 1;"; #get it defined
+   }
+}
 #########################
 
 # 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 strict;
 #use warnings;
 
 use Carp qw( carp cluck croak confess );
@@ -23,21 +30,22 @@
 
 sub hash { die { hash=>1 }; }
 sub immediate { die "immediate"; }
-sub forever { while ( 1 ) { 1; } } #read from stdin as a blocking call
+sub forever { while ( 1 ) { 1; } } 
 my $ret = 0;
 
+my $num_tests = 1; #start at 1 because of use_ok above
 eval { 
    $ret = timeout_call( 1, sub { hash(); } ); 
 };
-ok( (ref( $@ ) and exists($@->{'hash'}))  ,'die with hash' );
-ok( $ret == 0 ,'hash did not timeout' );
+ok( (ref( $@ ) and exists($@->{'hash'}))  ,'die with hash' ); $num_tests++;
+ok( $ret == 0 ,'hash did not timeout' ); $num_tests++;
 
 $ret = 0;
 eval { 
    $ret = timeout_call( 1, sub { immediate(); } ); 
 };
-ok( (not ref($@) and $@ ),'immediate -- die with string' );
-ok( $ret == 0 ,'immediate did not timeout' );
+ok( (not ref($@) and $@ ),'immediate -- die with string' ); $num_tests++;
+ok( $ret == 0 ,'immediate did not timeout' ); $num_tests++;
    
 $ret = 0;
 eval { 
@@ -48,9 +56,37 @@
 { 
    print "why did forever throw exception:" .Dumper( $@ );
 }
-ok( (not $@ ) ,'forever did NOT die' );
-ok( $ret ,'forever timed out' );
+ok( (not $@ ) ,'forever did NOT die' ); $num_tests++;
+ok( $ret ,'forever timed out' ); $num_tests++;
 
+
+if ( Sys::SigAction::have_hires() )
+{
+   $ret = 0;
+   my $btime;
+   my $etime;
+   eval { 
+      $btime = clock_gettime( CLOCK_REALTIME );
+      $ret = Sys::SigAction::timeout_call( 0.1, \&forever ); 
+   }; 
+   if ( $@ )
+   { 
+      print "hires: why did forever throw exception:" .Dumper( $@ );
+   }
+   $etime =  clock_gettime( CLOCK_REALTIME );
+#   diag(  $btime );
+#   diag(  $etime );
+#   diag(  ($etime-$btime) );
+
+   ok( (not $@ ) ,'hires: forever did NOT die' ); $num_tests++;
+   ok( $ret ,'hires: forever timed out' ); $num_tests++;
+   ok( (($etime - $btime) < 0.2 ), "hires: timeout in < 0.2 seconds" ); $num_tests++;
+}
+else
+{
+   diag "fractional second timeout test skipped: Time::HiRes is not installed" ;
+}
+plan tests => $num_tests;
 
 #foreach my $level ( @levels )
 #{




More information about the Pkg-perl-cvs-commits mailing list