update Time-HiRes to CPAN version 1.9724

- Correct XS parameter list, and therefore prototype, for
  unimplemented-on-this-platform version of clock_nanosleep()
  [rt.cpan.org #68700].
- Declare package variables with "our" rather than "use vars".
- Corresponding to "our" usage, check for minimum Perl version
  5.006.
- Declare module dependencies.

- Remove $ENV{PERL_CORE} logic from test suite, which is no
  longer desired in the core.
- Convert test suite to use Test::More.
- Factor out watchdog code from test suite.
- In test suite, be consistent about using fully-qualified form
  of function names.
- Divide test suite into feature-specific scripts.
- Make ualarm timing test less vulnerable to delay-induced false
  failure, from Dave Mitchell.

1 files changed, 222 insertions, 0 deletions

diff --git a/cpan/Time-HiRes/t/alarm.t b/cpan/Time-HiRes/t/alarm.t
new file mode 100644
index 0000000000..841694f67c
--- /dev/null
+++ b/cpan/Time-HiRes/t/alarm.t
@@ -0,0 +1,222 @@
+use strict;
+
+use Test::More 0.82 tests => 10;
+use t::Watchdog;
+
+BEGIN { require_ok "Time::HiRes"; }
+
+use Config;
+
+my $limit = 0.25; # 25% is acceptable slosh for testing timers
+
+my $xdefine = ''; 
+if (open(XDEFINE, "xdefine")) {
+    chomp($xdefine = <XDEFINE> || "");
+    close(XDEFINE);
+}
+
+my $can_subsecond_alarm =
+   defined &Time::HiRes::gettimeofday &&
+   defined &Time::HiRes::ualarm &&
+   defined &Time::HiRes::usleep &&
+   ($Config{d_ualarm} || $xdefine =~ /-DHAS_UALARM/);
+
+SKIP: {
+    skip "no subsecond alarm", 1 unless $can_subsecond_alarm;
+    eval { require POSIX };
+    my $use_sigaction =
+	!$@ && defined &POSIX::sigaction && &POSIX::SIGALRM > 0;
+
+    my ($r, $i, $not, $ok);
+
+    $r = [Time::HiRes::gettimeofday()];
+    $i = 5;
+    my $oldaction;
+    if ($use_sigaction) {
+	$oldaction = new POSIX::SigAction;
+	note sprintf "sigaction tick, ALRM = %d", &POSIX::SIGALRM;
+
+	# Perl's deferred signals may be too wimpy to break through
+	# a restartable select(), so use POSIX::sigaction if available.
+
+	POSIX::sigaction(&POSIX::SIGALRM,
+			 POSIX::SigAction->new("tick"),
+			 $oldaction)
+	    or die "Error setting SIGALRM handler with sigaction: $!\n";
+    } else {
+	note "SIG tick";
+	$SIG{ALRM} = "tick";
+    }
+
+    # On VMS timers can not interrupt select.
+    if ($^O eq 'VMS') {
+	$ok = "Skip: VMS select() does not get interrupted.";
+    } else {
+	while ($i > 0) {
+	    Time::HiRes::alarm(0.3);
+	    select (undef, undef, undef, 3);
+	    my $ival = Time::HiRes::tv_interval ($r);
+	    note "Select returned! $i $ival";
+	    note abs($ival/3 - 1);
+	    # Whether select() gets restarted after signals is
+	    # implementation dependent.  If it is restarted, we
+	    # will get about 3.3 seconds: 3 from the select, 0.3
+	    # from the alarm.  If this happens, let's just skip
+	    # this particular test.  --jhi
+	    if (abs($ival/3.3 - 1) < $limit) {
+		$ok = "Skip: your select() may get restarted by your SIGALRM (or just retry test)";
+		undef $not;
+		last;
+	    }
+	    my $exp = 0.3 * (5 - $i);
+	    if ($exp == 0) {
+		$not = "while: divisor became zero";
+		last;
+	    }
+	    # This test is more sensitive, so impose a softer limit.
+	    if (abs($ival/$exp - 1) > 4*$limit) {
+		my $ratio = abs($ival/$exp);
+		$not = "while: $exp sleep took $ival ratio $ratio";
+		last;
+	    }
+	    $ok = $i;
+	}
+    }
+
+    sub tick {
+	$i--;
+	my $ival = Time::HiRes::tv_interval ($r);
+	note "Tick! $i $ival";
+	my $exp = 0.3 * (5 - $i);
+	if ($exp == 0) {
+	    $not = "tick: divisor became zero";
+	    last;
+	}
+	# This test is more sensitive, so impose a softer limit.
+	if (abs($ival/$exp - 1) > 4*$limit) {
+	    my $ratio = abs($ival/$exp);
+	    $not = "tick: $exp sleep took $ival ratio $ratio";
+	    $i = 0;
+	}
+    }
+
+    if ($use_sigaction) {
+	POSIX::sigaction(&POSIX::SIGALRM, $oldaction);
+    } else {
+	Time::HiRes::alarm(0); # can't cancel usig %SIG
+    }
+
+    ok !$not;
+    note $not || $ok;
+}
+
+SKIP: {
+    skip "no ualarm", 1 unless &Time::HiRes::d_ualarm;
+    eval { Time::HiRes::alarm(-3) };
+    like $@, qr/::alarm\(-3, 0\): negative time not invented yet/,
+	    "negative time error";
+}
+
+# Find the loop size N (a for() loop 0..N-1)
+# that will take more than T seconds.
+
+SKIP: {
+    skip "no ualarm", 1 unless &Time::HiRes::d_ualarm;
+    skip "perl bug", 1 unless $] >= 5.008001;
+    # http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3
+    # Perl changes [18765] and [18770], perl bug [perl #20920]
+
+    note "Finding delay loop...";
+
+    my $T = 0.01;
+    my $DelayN = 1024;
+    my $i;
+ N: {
+     do {
+	 my $t0 = Time::HiRes::time();
+	 for ($i = 0; $i < $DelayN; $i++) { }
+	 my $t1 = Time::HiRes::time();
+	 my $dt = $t1 - $t0;
+	 note "N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt";
+	 last N if $dt > $T;
+	 $DelayN *= 2;
+     } while (1);
+ }
+
+    # The time-burner which takes at least T (default 1) seconds.
+    my $Delay = sub {
+	my $c = @_ ? shift : 1;
+	my $n = $c * $DelayN;
+	my $i;
+	for ($i = 0; $i < $n; $i++) { }
+    };
+
+    # Next setup a periodic timer (the two-argument alarm() of
+    # Time::HiRes, behind the curtains the libc getitimer() or
+    # ualarm()) which has a signal handler that takes so much time (on
+    # the first initial invocation) that the first periodic invocation
+    # (second invocation) will happen before the first invocation has
+    # finished.  In Perl 5.8.0 the "safe signals" concept was
+    # implemented, with unfortunately at least one bug that caused a
+    # core dump on reentering the handler. This bug was fixed by the
+    # time of Perl 5.8.1.
+
+    # Do not try mixing sleep() and alarm() for testing this.
+
+    my $a = 0; # Number of alarms we receive.
+    my $A = 2; # Number of alarms we will handle before disarming.
+               # (We may well get $A + 1 alarms.)
+
+    $SIG{ALRM} = sub {
+	$a++;
+	note "Alarm $a - ", Time::HiRes::time();
+	Time::HiRes::alarm(0) if $a >= $A; # Disarm the alarm.
+	$Delay->(2); # Try burning CPU at least for 2T seconds.
+    }; 
+
+    Time::HiRes::alarm($T, $T);  # Arm the alarm.
+
+    $Delay->(10); # Try burning CPU at least for 10T seconds.
+
+    ok 1; # Not core dumping by now is considered to be the success.
+}
+
+SKIP: {
+    skip "no subsecond alarm", 6 unless $can_subsecond_alarm;
+    {
+	my $alrm;
+	$SIG{ALRM} = sub { $alrm++ };
+	Time::HiRes::alarm(0.1);
+	my $t0 = Time::HiRes::time();
+	1 while Time::HiRes::time() - $t0 <= 1;
+	ok $alrm;
+    }
+    {
+	my $alrm;
+	$SIG{ALRM} = sub { $alrm++ };
+	Time::HiRes::alarm(1.1);
+	my $t0 = Time::HiRes::time();
+	1 while Time::HiRes::time() - $t0 <= 2;
+	ok $alrm;
+    }
+
+    {
+	my $alrm = 0;
+	$SIG{ALRM} = sub { $alrm++ };
+	my $got = Time::HiRes::alarm(2.7);
+	ok $got == 0 or note $got;
+
+	my $t0 = Time::HiRes::time();
+	1 while Time::HiRes::time() - $t0 <= 1;
+
+	$got = Time::HiRes::alarm(0);
+	ok $got > 0 && $got < 1.8 or note $got;
+
+	ok $alrm == 0 or note $alrm;
+
+	$got = Time::HiRes::alarm(0);
+	ok $got == 0 or note $got;
+    }
+}
+
+1;