summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--MANIFEST13
-rwxr-xr-xPorting/Maintainers.pl2
-rw-r--r--cpan/Time-HiRes/Changes20
-rw-r--r--cpan/Time-HiRes/HiRes.pm13
-rw-r--r--cpan/Time-HiRes/HiRes.xs2
-rw-r--r--cpan/Time-HiRes/Makefile.PL13
-rw-r--r--cpan/Time-HiRes/t/HiRes.t828
-rw-r--r--cpan/Time-HiRes/t/Watchdog.pm54
-rw-r--r--cpan/Time-HiRes/t/alarm.t222
-rw-r--r--cpan/Time-HiRes/t/clock.t94
-rw-r--r--cpan/Time-HiRes/t/gettimeofday.t33
-rw-r--r--cpan/Time-HiRes/t/itimer.t63
-rw-r--r--cpan/Time-HiRes/t/nanosleep.t35
-rw-r--r--cpan/Time-HiRes/t/sleep.t38
-rw-r--r--cpan/Time-HiRes/t/stat.t69
-rw-r--r--cpan/Time-HiRes/t/time.t23
-rw-r--r--cpan/Time-HiRes/t/tv_interval.t10
-rw-r--r--cpan/Time-HiRes/t/ualarm.t112
-rw-r--r--cpan/Time-HiRes/t/usleep.t78
-rwxr-xr-xt/TEST1
20 files changed, 883 insertions, 840 deletions
diff --git a/MANIFEST b/MANIFEST
index 777874fdc8..bde5b69722 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2523,7 +2523,18 @@ cpan/Time-HiRes/hints/svr4.pl Hints for Time::HiRes for named architecture
cpan/Time-HiRes/HiRes.pm Time::HiRes extension
cpan/Time-HiRes/HiRes.xs Time::HiRes extension
cpan/Time-HiRes/Makefile.PL Time::HiRes extension
-cpan/Time-HiRes/t/HiRes.t Test for Time::HiRes
+cpan/Time-HiRes/t/alarm.t Test for Time::HiRes
+cpan/Time-HiRes/t/clock.t Test for Time::HiRes
+cpan/Time-HiRes/t/gettimeofday.t Test for Time::HiRes
+cpan/Time-HiRes/t/itimer.t Test for Time::HiRes
+cpan/Time-HiRes/t/nanosleep.t Test for Time::HiRes
+cpan/Time-HiRes/t/sleep.t Test for Time::HiRes
+cpan/Time-HiRes/t/stat.t Test for Time::HiRes
+cpan/Time-HiRes/t/time.t Test for Time::HiRes
+cpan/Time-HiRes/t/tv_interval.t Test for Time::HiRes
+cpan/Time-HiRes/t/ualarm.t Test for Time::HiRes
+cpan/Time-HiRes/t/usleep.t Test for Time::HiRes
+cpan/Time-HiRes/t/Watchdog.pm Test for Time::HiRes
cpan/Time-HiRes/typemap Time::HiRes extension
cpan/Time-Local/lib/Time/Local.pm Reverse translation of localtime, gmtime
cpan/Time-Local/t/Local.t See if Time::Local works
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index ef4293fdbe..efbd9bda99 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -1921,7 +1921,7 @@ use File::Glob qw(:case);
'Time::HiRes' =>
{
'MAINTAINER' => 'zefram',
- 'DISTRIBUTION' => 'ZEFRAM/Time-HiRes-1.9722.tar.gz',
+ 'DISTRIBUTION' => 'ZEFRAM/Time-HiRes-1.9724.tar.gz',
'FILES' => q[cpan/Time-HiRes],
'UPSTREAM' => 'cpan',
},
diff --git a/cpan/Time-HiRes/Changes b/cpan/Time-HiRes/Changes
index 0515b8fa6f..206fa75485 100644
--- a/cpan/Time-HiRes/Changes
+++ b/cpan/Time-HiRes/Changes
@@ -1,5 +1,25 @@
Revision history for the Perl extension Time::HiRes.
+1.9724 [2011-06-09]
+ - 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.
+
+1.9723 [2011-06-07]
+ - 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.9722 [2011-05-18]
- Update for changes in build process in the core, patches
from BinGOs [rt.cpan.org #58858] and Craig Berry [rt.cpan.org
diff --git a/cpan/Time-HiRes/HiRes.pm b/cpan/Time-HiRes/HiRes.pm
index e6295a8085..30f954a2ce 100644
--- a/cpan/Time-HiRes/HiRes.pm
+++ b/cpan/Time-HiRes/HiRes.pm
@@ -1,15 +1,15 @@
package Time::HiRes;
+{ use 5.006; }
use strict;
-use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
require Exporter;
require DynaLoader;
-@ISA = qw(Exporter DynaLoader);
+our @ISA = qw(Exporter DynaLoader);
-@EXPORT = qw( );
-@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
+our @EXPORT = qw( );
+our @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
getitimer setitimer nanosleep clock_gettime clock_getres
clock clock_nanosleep
CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
@@ -23,10 +23,11 @@ require DynaLoader;
stat
);
-$VERSION = '1.9722';
-$XS_VERSION = $VERSION;
+our $VERSION = '1.9724';
+our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
+our $AUTOLOAD;
sub AUTOLOAD {
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
diff --git a/cpan/Time-HiRes/HiRes.xs b/cpan/Time-HiRes/HiRes.xs
index 970baa1bfa..32ac768861 100644
--- a/cpan/Time-HiRes/HiRes.xs
+++ b/cpan/Time-HiRes/HiRes.xs
@@ -1196,7 +1196,7 @@ clock_nanosleep(clock_id, nsec, flags = 0)
#else /* if defined(TIME_HIRES_CLOCK_NANOSLEEP) && defined(TIMER_ABSTIME) */
NV
-clock_nanosleep()
+clock_nanosleep(clock_id, nsec, flags = 0)
CODE:
croak("Time::HiRes::clock_nanosleep(): unimplemented in this platform");
RETVAL = 0.0;
diff --git a/cpan/Time-HiRes/Makefile.PL b/cpan/Time-HiRes/Makefile.PL
index 7766f29b2b..6f6a790077 100644
--- a/cpan/Time-HiRes/Makefile.PL
+++ b/cpan/Time-HiRes/Makefile.PL
@@ -5,7 +5,7 @@
# Use $ENV{FORCE_NANOSLEEP_SCAN} to force rescanning whether there
# really is hope.
-require 5.002;
+{ use 5.006; }
use Config;
use ExtUtils::MakeMaker;
@@ -17,7 +17,7 @@ my $LIBS = [];
my $XSOPT = '';
my $SYSCALL_H;
-use vars qw($self); # Used in 'sourcing' the hints.
+our $self; # Used in 'sourcing' the hints.
# TBD: Can we just use $Config(exe_ext) here instead of this complex
# expression?
@@ -759,6 +759,15 @@ sub doMakefile {
# Solaris will avenge.
'INC' => '', # e.g., '-I/usr/include/other'
'INSTALLDIRS' => ($] >= 5.008 ? 'perl' : 'site'),
+ 'PREREQ_PM' => {
+ 'Carp' => 0,
+ 'Config' => 0,
+ 'DynaLoader' => 0,
+ 'Exporter' => 0,
+ 'ExtUtils::MakeMaker' => 0,
+ 'Test::More' => "0.82",
+ 'strict' => 0,
+ },
'dist' => {
'CI' => 'ci -l',
'COMPRESS' => 'gzip -9f',
diff --git a/cpan/Time-HiRes/t/HiRes.t b/cpan/Time-HiRes/t/HiRes.t
deleted file mode 100644
index 0a38e78b04..0000000000
--- a/cpan/Time-HiRes/t/HiRes.t
+++ /dev/null
@@ -1,828 +0,0 @@
-#!./perl -w
-
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- if (" $Config{'extensions'} " !~ m[ Time/HiRes ]) {
- print "1..0 # Skip -- Perl configured without Time::HiRes module\n";
- exit 0;
- }
- }
-}
-
-BEGIN { $| = 1; print "1..48\n"; }
-
-END { print "not ok 1\n" unless $loaded }
-
-use Time::HiRes 1.9704; # Remember to bump this once in a while.
-use Time::HiRes qw(tv_interval);
-
-$loaded = 1;
-
-print "ok 1\n";
-
-use strict;
-
-my $have_gettimeofday = &Time::HiRes::d_gettimeofday;
-my $have_usleep = &Time::HiRes::d_usleep;
-my $have_nanosleep = &Time::HiRes::d_nanosleep;
-my $have_ualarm = &Time::HiRes::d_ualarm;
-my $have_clock_gettime = &Time::HiRes::d_clock_gettime;
-my $have_clock_getres = &Time::HiRes::d_clock_getres;
-my $have_clock_nanosleep = &Time::HiRes::d_clock_nanosleep;
-my $have_clock = &Time::HiRes::d_clock;
-my $have_hires_stat = &Time::HiRes::d_hires_stat;
-
-sub has_symbol {
- my $symbol = shift;
- eval "use Time::HiRes qw($symbol)";
- return 0 unless $@ eq '';
- eval "my \$a = $symbol";
- return $@ eq '';
-}
-
-printf "# have_gettimeofday = %d\n", $have_gettimeofday;
-printf "# have_usleep = %d\n", $have_usleep;
-printf "# have_nanosleep = %d\n", $have_nanosleep;
-printf "# have_ualarm = %d\n", $have_ualarm;
-printf "# have_clock_gettime = %d\n", $have_clock_gettime;
-printf "# have_clock_getres = %d\n", $have_clock_getres;
-printf "# have_clock_nanosleep = %d\n", $have_clock_nanosleep;
-printf "# have_clock = %d\n", $have_clock;
-printf "# have_hires_stat = %d\n", $have_hires_stat;
-
-import Time::HiRes 'gettimeofday' if $have_gettimeofday;
-import Time::HiRes 'usleep' if $have_usleep;
-import Time::HiRes 'nanosleep' if $have_nanosleep;
-import Time::HiRes 'ualarm' if $have_ualarm;
-import Time::HiRes 'clock_gettime' if $have_clock_gettime;
-import Time::HiRes 'clock_getres' if $have_clock_getres;
-import Time::HiRes 'clock_nanosleep' if $have_clock_nanosleep;
-import Time::HiRes 'clock' if $have_clock;
-
-use Config;
-
-use Time::HiRes qw(gettimeofday);
-
-my $have_alarm = $Config{d_alarm};
-my $have_fork = $Config{d_fork};
-my $waitfor = 360; # 30-45 seconds is normal (load affects this).
-my $timer_pid;
-my $TheEnd;
-
-if ($have_fork) {
- print "# I am the main process $$, starting the timer process...\n";
- $timer_pid = fork();
- if (defined $timer_pid) {
- if ($timer_pid == 0) { # We are the kid, set up the timer.
- my $ppid = getppid();
- print "# I am the timer process $$, sleeping for $waitfor seconds...\n";
- sleep($waitfor - 2); # Workaround for perlbug #49073
- sleep(2); # Wait for parent to exit
- if (kill(0, $ppid)) { # Check if parent still exists
- warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
- print "# Terminating main process $ppid...\n";
- kill('KILL', $ppid);
- print "# This is the timer process $$, over and out.\n";
- }
- exit(0);
- } else {
- print "# The timer process $timer_pid launched, continuing testing...\n";
- $TheEnd = time() + $waitfor;
- }
- } else {
- warn "$0: fork failed: $!\n";
- }
-} else {
- print "# No timer process (need fork)\n";
-}
-
-my $xdefine = '';
-
-if (open(XDEFINE, "xdefine")) {
- chomp($xdefine = <XDEFINE> || "");
- close(XDEFINE);
-}
-
-# Ideally, we'd like to test that the timers are rather precise.
-# However, if the system is busy, there are no guarantees on how
-# quickly we will return. This limit used to be 10%, but that
-# was occasionally triggered falsely.
-# So let's try 25%.
-# Another possibility might be to print "ok" if the test completes fine
-# with (say) 10% slosh, "skip - system may have been busy?" if the test
-# completes fine with (say) 30% slosh, and fail otherwise. If you do that,
-# consider changing over to test.pl at the same time.
-# --A.D., Nov 27, 2001
-my $limit = 0.25; # 25% is acceptable slosh for testing timers
-
-sub skip {
- map { print "ok $_ # skipped\n" } @_;
-}
-
-sub ok {
- my ($n, $result, @info) = @_;
- if ($result) {
- print "ok $n\n";
- }
- else {
- print "not ok $n\n";
- print "# @info\n" if @info;
- }
-}
-
-unless ($have_gettimeofday) {
- skip 2..6;
-}
-else {
- my @one = gettimeofday();
- ok 2, @one == 2, 'gettimeofday returned ', 0+@one, ' args';
- ok 3, $one[0] > 850_000_000, "@one too small";
-
- sleep 1;
-
- my @two = gettimeofday();
- ok 4, ($two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1])),
- "@two is not greater than @one";
-
- my $f = Time::HiRes::time();
- ok 5, $f > 850_000_000, "$f too small";
- ok 6, $f - $two[0] < 2, "$f - $two[0] >= 2";
-}
-
-unless ($have_usleep) {
- skip 7..8;
-}
-else {
- use Time::HiRes qw(usleep);
- my $one = time;
- usleep(10_000);
- my $two = time;
- usleep(10_000);
- my $three = time;
- ok 7, $one == $two || $two == $three, "slept too long, $one $two $three";
-
- unless ($have_gettimeofday) {
- skip 8;
- }
- else {
- my $f = Time::HiRes::time();
- usleep(500_000);
- my $f2 = Time::HiRes::time();
- my $d = $f2 - $f;
- ok 8, $d > 0.4 && $d < 0.9, "slept $d secs $f to $f2";
- }
-}
-
-# Two-arg tv_interval() is always available.
-{
- my $f = tv_interval [5, 100_000], [10, 500_000];
- ok 9, abs($f - 5.4) < 0.001, $f;
-}
-
-unless ($have_gettimeofday) {
- skip 10;
-}
-else {
- my $r = [gettimeofday()];
- my $f = tv_interval $r;
- ok 10, $f < 2, $f;
-}
-
-unless ($have_usleep && $have_gettimeofday) {
- skip 11;
-}
-else {
- my $r = [ gettimeofday() ];
- Time::HiRes::sleep( 0.5 );
- my $f = tv_interval $r;
- ok 11, $f > 0.4 && $f < 0.9, "slept $f instead of 0.5 secs.";
-}
-
-unless ($have_ualarm && $have_alarm) {
- skip 12..13;
-}
-else {
- my $tick = 0;
- local $SIG{ ALRM } = sub { $tick++ };
-
- my $one = time; $tick = 0; ualarm(10_000); while ($tick == 0) { }
- my $two = time; $tick = 0; ualarm(10_000); while ($tick == 0) { }
- my $three = time;
- ok 12, $one == $two || $two == $three, "slept too long, $one $two $three";
- print "# tick = $tick, one = $one, two = $two, three = $three\n";
-
- $tick = 0; ualarm(10_000, 10_000); while ($tick < 3) { }
- ok 13, 1;
- ualarm(0);
- print "# tick = $tick, one = $one, two = $two, three = $three\n";
-}
-
-# Did we even get close?
-
-unless ($have_gettimeofday) {
- skip 14;
-} else {
- my ($s, $n, $i) = (0);
- for $i (1 .. 100) {
- $s += Time::HiRes::time() - time();
- $n++;
- }
- # $s should be, at worst, equal to $n
- # (time() may be rounding down, up, or closest),
- # but allow 10% of slop.
- ok 14, abs($s) / $n <= 1.10, "Time::HiRes::time() not close to time()";
- print "# s = $s, n = $n, s/n = ", abs($s)/$n, "\n";
-}
-
-my $has_ualarm = $Config{d_ualarm};
-
-$has_ualarm ||= $xdefine =~ /-DHAS_UALARM/;
-
-my $can_subsecond_alarm =
- defined &Time::HiRes::gettimeofday &&
- defined &Time::HiRes::ualarm &&
- defined &Time::HiRes::usleep &&
- $has_ualarm;
-
-unless ($can_subsecond_alarm) {
- for (15..17) {
- print "ok $_ # Skip: no gettimeofday or no ualarm or no usleep\n";
- }
-} else {
- use Time::HiRes qw(time alarm sleep);
- eval { require POSIX };
- my $use_sigaction =
- !$@ && defined &POSIX::sigaction && &POSIX::SIGALRM > 0;
-
- my ($f, $r, $i, $not, $ok);
-
- $f = time;
- print "# time...$f\n";
- print "ok 15\n";
-
- $r = [Time::HiRes::gettimeofday()];
- sleep (0.5);
- print "# sleep...", Time::HiRes::tv_interval($r), "\nok 16\n";
-
- $r = [Time::HiRes::gettimeofday()];
- $i = 5;
- my $oldaction;
- if ($use_sigaction) {
- $oldaction = new POSIX::SigAction;
- printf "# sigaction tick, ALRM = %d\n", &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 {
- print "# SIG tick\n";
- $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) {
- alarm(0.3);
- select (undef, undef, undef, 3);
- my $ival = Time::HiRes::tv_interval ($r);
- print "# Select returned! $i $ival\n";
- print "# ", abs($ival/3 - 1), "\n";
- # 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);
- print "# Tick! $i $ival\n";
- 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 {
- alarm(0); # can't cancel usig %SIG
- }
-
- print $not ? "not ok 17 # $not\n" : "ok 17 # $ok\n";
-}
-
-unless (defined &Time::HiRes::setitimer
- && defined &Time::HiRes::getitimer
- && has_symbol('ITIMER_VIRTUAL')
- && $Config{sig_name} =~ m/\bVTALRM\b/
- && $^O ne 'nto' # nto: QNX 6 has the API but no implementation
- && $^O ne 'haiku' # haiku: has the API but no implementation
- ) {
- for (18..19) {
- print "ok $_ # Skip: no virtual interval timers\n";
- }
-} else {
- use Time::HiRes qw(setitimer getitimer ITIMER_VIRTUAL);
-
- my $i = 3;
- my $r = [Time::HiRes::gettimeofday()];
-
- $SIG{VTALRM} = sub {
- $i ? $i-- : setitimer(&ITIMER_VIRTUAL, 0);
- print "# Tick! $i ", Time::HiRes::tv_interval($r), "\n";
- };
-
- print "# setitimer: ", join(" ", setitimer(ITIMER_VIRTUAL, 0.5, 0.4)), "\n";
-
- # Assume interval timer granularity of $limit * 0.5 seconds. Too bold?
- my $virt = getitimer(&ITIMER_VIRTUAL);
- print "not " unless defined $virt && abs($virt / 0.5) - 1 < $limit;
- print "ok 18\n";
-
- print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
-
- while (getitimer(&ITIMER_VIRTUAL)) {
- my $j;
- for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer().
- }
-
- print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
-
- $virt = getitimer(&ITIMER_VIRTUAL);
- print "not " unless defined $virt && $virt == 0;
- print "ok 19\n";
-
- $SIG{VTALRM} = 'DEFAULT';
-}
-
-if ($have_gettimeofday &&
- $have_usleep) {
- use Time::HiRes qw(usleep);
-
- my ($t0, $td);
-
- my $sleep = 1.5; # seconds
- my $msg;
-
- $t0 = gettimeofday();
- $a = abs(sleep($sleep) / $sleep - 1.0);
- $td = gettimeofday() - $t0;
- my $ratio = 1.0 + $a;
-
- $msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
-
- if ($td < $sleep * (1 + $limit)) {
- print $a < $limit ? "ok 20 # $msg" : "not ok 20 # $msg";
- } else {
- print "ok 20 # Skip: $msg";
- }
-
- $t0 = gettimeofday();
- $a = abs(usleep($sleep * 1E6) / ($sleep * 1E6) - 1.0);
- $td = gettimeofday() - $t0;
- $ratio = 1.0 + $a;
-
- $msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
-
- if ($td < $sleep * (1 + $limit)) {
- print $a < $limit ? "ok 21 # $msg" : "not ok 21 # $msg";
- } else {
- print "ok 21 # Skip: $msg";
- }
-
-} else {
- for (20..21) {
- print "ok $_ # Skip: no gettimeofday\n";
- }
-}
-
-unless ($have_nanosleep) {
- skip 22..23;
-}
-else {
- my $one = CORE::time;
- nanosleep(10_000_000);
- my $two = CORE::time;
- nanosleep(10_000_000);
- my $three = CORE::time;
- ok 22, $one == $two || $two == $three, "slept too long, $one $two $three";
-
- unless ($have_gettimeofday) {
- skip 23;
- }
- else {
- my $f = Time::HiRes::time();
- nanosleep(500_000_000);
- my $f2 = Time::HiRes::time();
- my $d = $f2 - $f;
- ok 23, $d > 0.4 && $d < 0.9, "slept $d secs $f to $f2";
- }
-}
-
-eval { sleep(-1) };
-print $@ =~ /::sleep\(-1\): negative time not invented yet/ ?
- "ok 24\n" : "not ok 24\n";
-
-eval { usleep(-2) };
-print $@ =~ /::usleep\(-2\): negative time not invented yet/ ?
- "ok 25\n" : "not ok 25\n";
-
-if ($have_ualarm) {
- eval { alarm(-3) };
- print $@ =~ /::alarm\(-3, 0\): negative time not invented yet/ ?
- "ok 26\n" : "not ok 26\n";
-
- eval { ualarm(-4) };
- print $@ =~ /::ualarm\(-4, 0\): negative time not invented yet/ ?
- "ok 27\n" : "not ok 27\n";
-} else {
- skip 26;
- skip 27;
-}
-
-if ($have_nanosleep) {
- eval { nanosleep(-5) };
- print $@ =~ /::nanosleep\(-5\): negative time not invented yet/ ?
- "ok 28\n" : "not ok 28\n";
-} else {
- skip 28;
-}
-
-# Find the loop size N (a for() loop 0..N-1)
-# that will take more than T seconds.
-
-if ($have_ualarm && $] >= 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]
-
- print "# Finding delay loop...\n";
-
- my $T = 0.01;
- use Time::HiRes qw(time);
- my $DelayN = 1024;
- my $i;
- N: {
- do {
- my $t0 = time();
- for ($i = 0; $i < $DelayN; $i++) { }
- my $t1 = time();
- my $dt = $t1 - $t0;
- print "# N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt\n";
- 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++;
- print "# Alarm $a - ", time(), "\n";
- alarm(0) if $a >= $A; # Disarm the alarm.
- $Delay->(2); # Try burning CPU at least for 2T seconds.
- };
-
- use Time::HiRes qw(alarm);
- alarm($T, $T); # Arm the alarm.
-
- $Delay->(10); # Try burning CPU at least for 10T seconds.
-
- print "ok 29\n"; # Not core dumping by now is considered to be the success.
-} else {
- skip 29;
-}
-
-if ($have_clock_gettime &&
- # All implementations of clock_gettime()
- # are SUPPOSED TO support CLOCK_REALTIME.
- has_symbol('CLOCK_REALTIME')) {
- my $ok = 0;
- TRY: {
- for my $try (1..3) {
- print "# CLOCK_REALTIME: try = $try\n";
- my $t0 = clock_gettime(&CLOCK_REALTIME);
- use Time::HiRes qw(sleep);
- my $T = 1.5;
- sleep($T);
- my $t1 = clock_gettime(&CLOCK_REALTIME);
- if ($t0 > 0 && $t1 > $t0) {
- print "# t1 = $t1, t0 = $t0\n";
- my $dt = $t1 - $t0;
- my $rt = abs(1 - $dt / $T);
- print "# dt = $dt, rt = $rt\n";
- if ($rt <= 2 * $limit) {
- $ok = 1;
- last TRY;
- }
- } else {
- print "# Error: t0 = $t0, t1 = $t1\n";
- }
- my $r = rand() + rand();
- printf "# Sleeping for %.6f seconds...\n", $r;
- sleep($r);
- }
- }
- if ($ok) {
- print "ok 30\n";
- } else {
- print "not ok 30\n";
- }
-} else {
- print "# No clock_gettime\n";
- skip 30;
-}
-
-if ($have_clock_getres) {
- my $tr = clock_getres();
- if ($tr > 0) {
- print "ok 31 # tr = $tr\n";
- } else {
- print "not ok 31 # tr = $tr\n";
- }
-} else {
- print "# No clock_getres\n";
- skip 31;
-}
-
-if ($have_clock_nanosleep &&
- has_symbol('CLOCK_REALTIME')) {
- my $s = 1.5e9;
- my $t = clock_nanosleep(&CLOCK_REALTIME, $s);
- my $r = abs(1 - $t / $s);
- if ($r < 2 * $limit) {
- print "ok 32\n";
- } else {
- print "not ok 32 # $t = $t, r = $r\n";
- }
-} else {
- print "# No clock_nanosleep\n";
- skip 32;
-}
-
-if ($have_clock) {
- my @clock = clock();
- print "# clock = @clock\n";
- for my $i (1..3) {
- for (my $j = 0; $j < 1e6; $j++) { }
- push @clock, clock();
- print "# clock = @clock\n";
- }
- if ($clock[0] >= 0 &&
- $clock[1] > $clock[0] &&
- $clock[2] > $clock[1] &&
- $clock[3] > $clock[2]) {
- print "ok 33\n";
- } else {
- print "not ok 33\n";
- }
-} else {
- skip 33;
-}
-
-sub bellish { # Cheap emulation of a bell curve.
- my ($min, $max) = @_;
- my $rand = ($max - $min) / 5;
- my $sum = 0;
- for my $i (0..4) {
- $sum += rand($rand);
- }
- return $min + $sum;
-}
-
-if ($have_ualarm) {
- # 1_100_000 sligthly over 1_000_000,
- # 2_200_000 slightly over 2**31/1000,
- # 4_300_000 slightly over 2**32/1000.
- for my $t ([34, 100_000],
- [35, 1_100_000],
- [36, 2_200_000],
- [37, 4_300_000]) {
- my ($i, $n) = @$t;
- my $ok;
- for my $retry (1..10) {
- my $alarmed = 0;
- local $SIG{ ALRM } = sub { $alarmed++ };
- my $t0 = Time::HiRes::time();
- print "# t0 = $t0\n";
- print "# ualarm($n)\n";
- ualarm($n); 1 while $alarmed == 0;
- my $t1 = Time::HiRes::time();
- print "# t1 = $t1\n";
- my $dt = $t1 - $t0;
- print "# dt = $dt\n";
- my $r = $dt / ($n/1e6);
- print "# r = $r\n";
- $ok =
- ($n < 1_000_000 || # Too much noise.
- ($r >= 0.8 && $r <= 1.6));
- last if $ok;
- my $nap = bellish(3, 15);
- printf "# Retrying in %.1f seconds...\n", $nap;
- Time::HiRes::sleep($nap);
- }
- ok $i, $ok, "ualarm($n) close enough";
- }
-} else {
- print "# No ualarm\n";
- skip 34..37;
-}
-
-if ($^O =~ /^(cygwin|MSWin)/) {
- print "# $^O: timestamps may not be good enough\n";
- skip 38;
-} elsif (&Time::HiRes::d_hires_stat) {
- my @stat;
- my @atime;
- my @mtime;
- for (1..5) {
- Time::HiRes::sleep(rand(0.1) + 0.1);
- open(X, ">$$");
- print X $$;
- close(X);
- @stat = Time::HiRes::stat($$);
- push @mtime, $stat[9];
- Time::HiRes::sleep(rand(0.1) + 0.1);
- open(X, "<$$");
- <X>;
- close(X);
- @stat = Time::HiRes::stat($$);
- push @atime, $stat[8];
- }
- 1 while unlink $$;
- print "# mtime = @mtime\n";
- print "# atime = @atime\n";
- my $ai = 0;
- my $mi = 0;
- my $ss = 0;
- for (my $i = 1; $i < @atime; $i++) {
- if ($atime[$i] >= $atime[$i-1]) {
- $ai++;
- }
- if ($atime[$i] > int($atime[$i])) {
- $ss++;
- }
- }
- for (my $i = 1; $i < @mtime; $i++) {
- if ($mtime[$i] >= $mtime[$i-1]) {
- $mi++;
- }
- if ($mtime[$i] > int($mtime[$i])) {
- $ss++;
- }
- }
- print "# ai = $ai, mi = $mi, ss = $ss\n";
- # Need at least 75% of monotonical increase and
- # 20% of subsecond results. Yes, this is guessing.
- if ($ss == 0) {
- print "# No subsecond timestamps detected\n";
- skip 38;
- } elsif ($mi/(@mtime-1) >= 0.75 && $ai/(@atime-1) >= 0.75 &&
- $ss/(@mtime+@atime) >= 0.2) {
- print "ok 38\n";
- } else {
- print "not ok 38\n";
- }
-} else {
- print "# No effectual d_hires_stat\n";
- skip 38;
-}
-
-unless ($can_subsecond_alarm) {
- skip 39..44;
-} else {
- {
- my $alrm;
- $SIG{ALRM} = sub { $alrm++ };
- Time::HiRes::alarm(0.1);
- my $t0 = time();
- 1 while time() - $t0 <= 1;
- print $alrm ? "ok 39\n" : "not ok 39\n";
- }
- {
- my $alrm;
- $SIG{ALRM} = sub { $alrm++ };
- Time::HiRes::alarm(1.1);
- my $t0 = time();
- 1 while time() - $t0 <= 2;
- print $alrm ? "ok 40\n" : "not ok 40\n";
- }
-
- {
- my $alrm = 0;
- $SIG{ALRM} = sub { $alrm++ };
- my $got = Time::HiRes::alarm(2.7);
- ok(41, $got == 0, $got);
-
- my $t0 = time();
- 1 while time() - $t0 <= 1;
-
- $got = Time::HiRes::alarm(0);
- ok(42, $got > 0 && $got < 1.8, $got);
-
- ok(43, $alrm == 0, $alrm);
-
- $got = Time::HiRes::alarm(0);
- ok(44, $got == 0, $got);
- }
-}
-
-unless ($have_ualarm) {
- skip 45..48;
-}
-else {
- {
- my $alrm = 0;
- $SIG{ALRM} = sub { $alrm++ };
- my $got = Time::HiRes::ualarm(500_000);
- ok(45, $got == 0, $got);
-
- my $t0 = Time::HiRes::time();
- my $t1;
- do {
- $t1 = Time::HiRes::time();
- } while $t1 - $t0 <= 0.3;
- print "# t0 = $t0\n# t1 = $t1\n# t1 - t0 = ", ($t1 - $t0), "\n";
-
- $got = Time::HiRes::ualarm(0);
- ok(46, $got > 0 && $got < 300_000, $got);
-
- ok(47, $alrm == 0, $alrm);
-
- $got = Time::HiRes::ualarm(0);
- ok(48, $got == 0, $got);
- }
-}
-
-END {
- if ($timer_pid) { # Only in the main process.
- my $left = $TheEnd - time();
- printf "# I am the main process $$, terminating the timer process $timer_pid\n# before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left;
- if (kill(0, $timer_pid)) {
- local $? = 0;
- my $kill = kill('KILL', $timer_pid); # We are done, the timer can go.
- wait();
- printf "# kill KILL $timer_pid = %d\n", $kill;
- }
- unlink("ktrace.out"); # Used in BSD system call tracing.
- print "# All done.\n";
- }
-}
-
diff --git a/cpan/Time-HiRes/t/Watchdog.pm b/cpan/Time-HiRes/t/Watchdog.pm
new file mode 100644
index 0000000000..83e854396f
--- /dev/null
+++ b/cpan/Time-HiRes/t/Watchdog.pm
@@ -0,0 +1,54 @@
+package t::Watchdog;
+
+use strict;
+
+use Config;
+use Test::More;
+
+my $waitfor = 360; # 30-45 seconds is normal (load affects this).
+my $watchdog_pid;
+my $TheEnd;
+
+if ($Config{d_fork}) {
+ note "I am the main process $$, starting the watchdog process...";
+ $watchdog_pid = fork();
+ if (defined $watchdog_pid) {
+ if ($watchdog_pid == 0) { # We are the kid, set up the watchdog.
+ my $ppid = getppid();
+ note "I am the watchdog process $$, sleeping for $waitfor seconds...";
+ sleep($waitfor - 2); # Workaround for perlbug #49073
+ sleep(2); # Wait for parent to exit
+ if (kill(0, $ppid)) { # Check if parent still exists
+ warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
+ note "Terminating main process $ppid...";
+ kill('KILL', $ppid);
+ note "This is the watchdog process $$, over and out.";
+ }
+ exit(0);
+ } else {
+ note "The watchdog process $watchdog_pid launched, continuing testing...";
+ $TheEnd = time() + $waitfor;
+ }
+ } else {
+ warn "$0: fork failed: $!\n";
+ }
+} else {
+ note "No watchdog process (need fork)";
+}
+
+END {
+ if ($watchdog_pid) { # Only in the main process.
+ my $left = $TheEnd - time();
+ note sprintf "I am the main process $$, terminating the watchdog process $watchdog_pid before it terminates me in %d seconds (testing took %d seconds).", $left, $waitfor - $left;
+ if (kill(0, $watchdog_pid)) {
+ local $? = 0;
+ my $kill = kill('KILL', $watchdog_pid); # We are done, the watchdog can go.
+ wait();
+ note sprintf "kill KILL $watchdog_pid = %d", $kill;
+ }
+ unlink("ktrace.out"); # Used in BSD system call tracing.
+ note "All done.";
+ }
+}
+
+1;
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;
diff --git a/cpan/Time-HiRes/t/clock.t b/cpan/Time-HiRes/t/clock.t
new file mode 100644
index 0000000000..6d11dd2ca0
--- /dev/null
+++ b/cpan/Time-HiRes/t/clock.t
@@ -0,0 +1,94 @@
+use strict;
+
+use Test::More 0.82 tests => 5;
+use t::Watchdog;
+
+BEGIN { require_ok "Time::HiRes"; }
+
+sub has_symbol {
+ my $symbol = shift;
+ eval "use Time::HiRes qw($symbol)";
+ return 0 unless $@ eq '';
+ eval "my \$a = $symbol";
+ return $@ eq '';
+}
+
+note sprintf "have_clock_gettime = %d", &Time::HiRes::d_clock_gettime;
+note sprintf "have_clock_getres = %d", &Time::HiRes::d_clock_getres;
+note sprintf "have_clock_nanosleep = %d", &Time::HiRes::d_clock_nanosleep;
+note sprintf "have_clock = %d", &Time::HiRes::d_clock;
+
+# Ideally, we'd like to test that the timers are rather precise.
+# However, if the system is busy, there are no guarantees on how
+# quickly we will return. This limit used to be 10%, but that
+# was occasionally triggered falsely.
+# So let's try 25%.
+# Another possibility might be to print "ok" if the test completes fine
+# with (say) 10% slosh, "skip - system may have been busy?" if the test
+# completes fine with (say) 30% slosh, and fail otherwise. If you do that,
+# consider changing over to test.pl at the same time.
+# --A.D., Nov 27, 2001
+my $limit = 0.25; # 25% is acceptable slosh for testing timers
+
+SKIP: {
+ skip "no clock_gettime", 1
+ unless &Time::HiRes::d_clock_gettime && has_symbol("CLOCK_REALTIME");
+ my $ok = 0;
+ TRY: {
+ for my $try (1..3) {
+ note "CLOCK_REALTIME: try = $try";
+ my $t0 = Time::HiRes::clock_gettime(&CLOCK_REALTIME);
+ my $T = 1.5;
+ Time::HiRes::sleep($T);
+ my $t1 = Time::HiRes::clock_gettime(&CLOCK_REALTIME);
+ if ($t0 > 0 && $t1 > $t0) {
+ note "t1 = $t1, t0 = $t0";
+ my $dt = $t1 - $t0;
+ my $rt = abs(1 - $dt / $T);
+ note "dt = $dt, rt = $rt";
+ if ($rt <= 2 * $limit) {
+ $ok = 1;
+ last TRY;
+ }
+ } else {
+ note "Error: t0 = $t0, t1 = $t1";
+ }
+ my $r = rand() + rand();
+ note sprintf "Sleeping for %.6f seconds...\n", $r;
+ Time::HiRes::sleep($r);
+ }
+ }
+ ok $ok;
+}
+
+SKIP: {
+ skip "no clock_getres", 1 unless &Time::HiRes::d_clock_getres;
+ my $tr = Time::HiRes::clock_getres();
+ ok $tr > 0 or note "tr = $tr";
+}
+
+SKIP: {
+ skip "no clock_nanosleep", 1
+ unless &Time::HiRes::d_clock_nanosleep && has_symbol("CLOCK_REALTIME");
+ my $s = 1.5e9;
+ my $t = Time::HiRes::clock_nanosleep(&CLOCK_REALTIME, $s);
+ my $r = abs(1 - $t / $s);
+ ok $r < 2 * $limit or note "t = $t, r = $r";
+}
+
+SKIP: {
+ skip "no clock", 1 unless &Time::HiRes::d_clock;
+ my @clock = Time::HiRes::clock();
+ note "clock = @clock";
+ for my $i (1..3) {
+ for (my $j = 0; $j < 1e6; $j++) { }
+ push @clock, Time::HiRes::clock();
+ note "clock = @clock";
+ }
+ ok $clock[0] >= 0 &&
+ $clock[1] > $clock[0] &&
+ $clock[2] > $clock[1] &&
+ $clock[3] > $clock[2];
+}
+
+1;
diff --git a/cpan/Time-HiRes/t/gettimeofday.t b/cpan/Time-HiRes/t/gettimeofday.t
new file mode 100644
index 0000000000..8f7c5f3039
--- /dev/null
+++ b/cpan/Time-HiRes/t/gettimeofday.t
@@ -0,0 +1,33 @@
+use strict;
+
+BEGIN {
+ require Time::HiRes;
+ unless(&Time::HiRes::d_gettimeofday) {
+ require Test::More;
+ Test::More::plan(skip_all => "no gettimeofday()");
+ }
+}
+
+use Test::More 0.82 tests => 6;
+use t::Watchdog;
+
+my @one = Time::HiRes::gettimeofday();
+note 'gettimeofday returned ', 0+@one, ' args';
+ok @one == 2;
+ok $one[0] > 850_000_000 or note "@one too small";
+
+sleep 1;
+
+my @two = Time::HiRes::gettimeofday();
+ok $two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1])
+ or note "@two is not greater than @one";
+
+my $f = Time::HiRes::time();
+ok $f > 850_000_000 or note "$f too small";
+ok $f - $two[0] < 2 or note "$f - $two[0] >= 2";
+
+my $r = [Time::HiRes::gettimeofday()];
+my $g = Time::HiRes::tv_interval $r;
+ok $g < 2 or note $g;
+
+1;
diff --git a/cpan/Time-HiRes/t/itimer.t b/cpan/Time-HiRes/t/itimer.t
new file mode 100644
index 0000000000..7877f6364d
--- /dev/null
+++ b/cpan/Time-HiRes/t/itimer.t
@@ -0,0 +1,63 @@
+use strict;
+
+sub has_symbol {
+ my $symbol = shift;
+ eval "use Time::HiRes qw($symbol)";
+ return 0 unless $@ eq '';
+ eval "my \$a = $symbol";
+ return $@ eq '';
+}
+
+use Config;
+
+BEGIN {
+ require Time::HiRes;
+ unless(defined &Time::HiRes::setitimer
+ && defined &Time::HiRes::getitimer
+ && has_symbol('ITIMER_VIRTUAL')
+ && $Config{sig_name} =~ m/\bVTALRM\b/
+ && $^O ne 'nto' # nto: QNX 6 has the API but no implementation
+ && $^O ne 'haiku' # haiku: has the API but no implementation
+ ) {
+ require Test::More;
+ Test::More::plan(skip_all => "no itimer");
+ }
+}
+
+use Test::More 0.82 tests => 2;
+use t::Watchdog;
+
+my $limit = 0.25; # 25% is acceptable slosh for testing timers
+
+my $i = 3;
+my $r = [Time::HiRes::gettimeofday()];
+
+$SIG{VTALRM} = sub {
+ $i ? $i-- : Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0);
+ note "Tick! $i ", Time::HiRes::tv_interval($r);
+};
+
+note "setitimer: ", join(" ",
+ Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0.5, 0.4));
+
+# Assume interval timer granularity of $limit * 0.5 seconds. Too bold?
+my $virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL);
+ok defined $virt && abs($virt / 0.5) - 1 < $limit;
+
+note "getitimer: ", join(" ",
+ Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL));
+
+while (Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)) {
+ my $j;
+ for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer().
+}
+
+note "getitimer: ", join(" ",
+ Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL));
+
+$virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL);
+ok defined $virt && $virt == 0;
+
+$SIG{VTALRM} = 'DEFAULT';
+
+1;
diff --git a/cpan/Time-HiRes/t/nanosleep.t b/cpan/Time-HiRes/t/nanosleep.t
new file mode 100644
index 0000000000..aef9db6163
--- /dev/null
+++ b/cpan/Time-HiRes/t/nanosleep.t
@@ -0,0 +1,35 @@
+use strict;
+
+BEGIN {
+ require Time::HiRes;
+ unless(&Time::HiRes::d_nanosleep) {
+ require Test::More;
+ Test::More::plan(skip_all => "no nanosleep()");
+ }
+}
+
+use Test::More 0.82 tests => 3;
+use t::Watchdog;
+
+eval { Time::HiRes::nanosleep(-5) };
+like $@, qr/::nanosleep\(-5\): negative time not invented yet/,
+ "negative time error";
+
+my $one = CORE::time;
+Time::HiRes::nanosleep(10_000_000);
+my $two = CORE::time;
+Time::HiRes::nanosleep(10_000_000);
+my $three = CORE::time;
+ok $one == $two || $two == $three
+ or note "slept too long, $one $two $three";
+
+SKIP: {
+ skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday;
+ my $f = Time::HiRes::time();
+ Time::HiRes::nanosleep(500_000_000);
+ my $f2 = Time::HiRes::time();
+ my $d = $f2 - $f;
+ ok $d > 0.4 && $d < 0.9 or note "slept $d secs $f to $f2";
+}
+
+1;
diff --git a/cpan/Time-HiRes/t/sleep.t b/cpan/Time-HiRes/t/sleep.t
new file mode 100644
index 0000000000..e7cc6271a8
--- /dev/null
+++ b/cpan/Time-HiRes/t/sleep.t
@@ -0,0 +1,38 @@
+use strict;
+
+use Test::More 0.82 tests => 4;
+use t::Watchdog;
+
+BEGIN { require_ok "Time::HiRes"; }
+
+use Config;
+
+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/);
+
+eval { Time::HiRes::sleep(-1) };
+like $@, qr/::sleep\(-1\): negative time not invented yet/,
+ "negative time error";
+
+SKIP: {
+ skip "no subsecond alarm", 2 unless $can_subsecond_alarm;
+ my $f = Time::HiRes::time;
+ note "time...$f";
+ ok 1;
+
+ my $r = [Time::HiRes::gettimeofday()];
+ Time::HiRes::sleep (0.5);
+ note "sleep...", Time::HiRes::tv_interval($r);
+ ok 1;
+}
+
+1;
diff --git a/cpan/Time-HiRes/t/stat.t b/cpan/Time-HiRes/t/stat.t
new file mode 100644
index 0000000000..406fdc31ca
--- /dev/null
+++ b/cpan/Time-HiRes/t/stat.t
@@ -0,0 +1,69 @@
+use strict;
+
+BEGIN {
+ require Time::HiRes;
+ unless(&Time::HiRes::d_hires_stat) {
+ require Test::More;
+ Test::More::plan(skip_all => "no hi-res stat");
+ }
+ if($^O =~ /\A(?:cygwin|MSWin)/) {
+ require Test::More;
+ Test::More::plan(skip_all =>
+ "$^O file timestamps not reliable enough for stat test");
+ }
+}
+
+use Test::More 0.82 tests => 1;
+use t::Watchdog;
+
+my $limit = 0.25; # 25% is acceptable slosh for testing timers
+
+my @stat;
+my @atime;
+my @mtime;
+for (1..5) {
+ Time::HiRes::sleep(rand(0.1) + 0.1);
+ open(X, ">$$");
+ print X $$;
+ close(X);
+ @stat = Time::HiRes::stat($$);
+ push @mtime, $stat[9];
+ Time::HiRes::sleep(rand(0.1) + 0.1);
+ open(X, "<$$");
+ <X>;
+ close(X);
+ @stat = Time::HiRes::stat($$);
+ push @atime, $stat[8];
+}
+1 while unlink $$;
+note "mtime = @mtime";
+note "atime = @atime";
+my $ai = 0;
+my $mi = 0;
+my $ss = 0;
+for (my $i = 1; $i < @atime; $i++) {
+ if ($atime[$i] >= $atime[$i-1]) {
+ $ai++;
+ }
+ if ($atime[$i] > int($atime[$i])) {
+ $ss++;
+ }
+}
+for (my $i = 1; $i < @mtime; $i++) {
+ if ($mtime[$i] >= $mtime[$i-1]) {
+ $mi++;
+ }
+ if ($mtime[$i] > int($mtime[$i])) {
+ $ss++;
+ }
+}
+note "ai = $ai, mi = $mi, ss = $ss";
+# Need at least 75% of monotonical increase and
+# 20% of subsecond results. Yes, this is guessing.
+SKIP: {
+ skip "no subsecond timestamps detected", 1 if $ss == 0;
+ ok $mi/(@mtime-1) >= 0.75 && $ai/(@atime-1) >= 0.75 &&
+ $ss/(@mtime+@atime) >= 0.2;
+}
+
+1;
diff --git a/cpan/Time-HiRes/t/time.t b/cpan/Time-HiRes/t/time.t
new file mode 100644
index 0000000000..feec4799d9
--- /dev/null
+++ b/cpan/Time-HiRes/t/time.t
@@ -0,0 +1,23 @@
+use strict;
+
+use Test::More 0.82 tests => 2;
+use t::Watchdog;
+
+BEGIN { require_ok "Time::HiRes"; }
+
+SKIP: {
+ skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday;
+ my ($s, $n, $i) = (0);
+ for $i (1 .. 100) {
+ $s += Time::HiRes::time() - CORE::time();
+ $n++;
+ }
+ # $s should be, at worst, equal to $n
+ # (CORE::time() may be rounding down, up, or closest),
+ # but allow 10% of slop.
+ ok abs($s) / $n <= 1.10
+ or note "Time::HiRes::time() not close to CORE::time()";
+ note "s = $s, n = $n, s/n = ", abs($s)/$n;
+}
+
+1;
diff --git a/cpan/Time-HiRes/t/tv_interval.t b/cpan/Time-HiRes/t/tv_interval.t
new file mode 100644
index 0000000000..bffcf39ec1
--- /dev/null
+++ b/cpan/Time-HiRes/t/tv_interval.t
@@ -0,0 +1,10 @@
+use strict;
+
+use Test::More 0.82 tests => 2;
+
+BEGIN { require_ok "Time::HiRes"; }
+
+my $f = Time::HiRes::tv_interval [5, 100_000], [10, 500_000];
+ok abs($f - 5.4) < 0.001 or note $f;
+
+1;
diff --git a/cpan/Time-HiRes/t/ualarm.t b/cpan/Time-HiRes/t/ualarm.t
new file mode 100644
index 0000000000..12ef4b52cc
--- /dev/null
+++ b/cpan/Time-HiRes/t/ualarm.t
@@ -0,0 +1,112 @@
+use strict;
+
+BEGIN {
+ require Time::HiRes;
+ unless(&Time::HiRes::d_ualarm) {
+ require Test::More;
+ Test::More::plan(skip_all => "no ualarm()");
+ }
+}
+
+use Test::More 0.82 tests => 12;
+use t::Watchdog;
+
+use Config;
+
+SKIP: {
+ skip "no alarm", 2 unless $Config{d_alarm};
+ my $tick = 0;
+ local $SIG{ ALRM } = sub { $tick++ };
+
+ my $one = CORE::time;
+ $tick = 0; Time::HiRes::ualarm(10_000); while ($tick == 0) { }
+ my $two = CORE::time;
+ $tick = 0; Time::HiRes::ualarm(10_000); while ($tick == 0) { }
+ my $three = CORE::time;
+ ok $one == $two || $two == $three
+ or note "slept too long, $one $two $three";
+ note "tick = $tick, one = $one, two = $two, three = $three";
+
+ $tick = 0; Time::HiRes::ualarm(10_000, 10_000); while ($tick < 3) { }
+ ok 1;
+ Time::HiRes::ualarm(0);
+ note "tick = $tick, one = $one, two = $two, three = $three";
+}
+
+eval { Time::HiRes::ualarm(-4) };
+like $@, qr/::ualarm\(-4, 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.
+
+sub bellish { # Cheap emulation of a bell curve.
+ my ($min, $max) = @_;
+ my $rand = ($max - $min) / 5;
+ my $sum = 0;
+ for my $i (0..4) {
+ $sum += rand($rand);
+ }
+ return $min + $sum;
+}
+
+# 1_100_000 slightly over 1_000_000,
+# 2_200_000 slightly over 2**31/1000,
+# 4_300_000 slightly over 2**32/1000.
+for my $n (100_000, 1_100_000, 2_200_000, 4_300_000) {
+ my $ok;
+ for my $retry (1..10) {
+ my $alarmed = 0;
+ local $SIG{ ALRM } = sub { $alarmed++ };
+ my $t0 = Time::HiRes::time();
+ note "t0 = $t0";
+ note "ualarm($n)";
+ Time::HiRes::ualarm($n); 1 while $alarmed == 0;
+ my $t1 = Time::HiRes::time();
+ note "t1 = $t1";
+ my $dt = $t1 - $t0;
+ note "dt = $dt";
+ my $r = $dt / ($n/1e6);
+ note "r = $r";
+ $ok =
+ ($n < 1_000_000 || # Too much noise.
+ ($r >= 0.8 && $r <= 1.6));
+ last if $ok;
+ my $nap = bellish(3, 15);
+ note sprintf "Retrying in %.1f seconds...\n", $nap;
+ Time::HiRes::sleep($nap);
+ }
+ ok $ok or note "ualarm($n) close enough";
+}
+
+{
+ my $alrm0 = 0;
+
+ $SIG{ALRM} = sub { $alrm0++ };
+ my $t0 = Time::HiRes::time();
+ my $got0 = Time::HiRes::ualarm(500_000);
+
+ my($alrm, $t1);
+ do {
+ $alrm = $alrm0;
+ $t1 = Time::HiRes::time();
+ } while $t1 - $t0 <= 0.3;
+ my $got1 = Time::HiRes::ualarm(0);
+
+ note "t0 = $t0";
+ note "got0 = $got0";
+ note "t1 = $t1";
+ note "t1 - t0 = ", ($t1 - $t0);
+ note "got1 = $got1";
+ ok $got0 == 0 or note $got0;
+ SKIP: {
+ skip "alarm interval exceeded", 2 if $t1 - $t0 >= 0.5;
+ ok $got1 > 0;
+ ok $alrm == 0;
+ }
+ ok $got1 < 300_000;
+ my $got2 = Time::HiRes::ualarm(0);
+ ok $got2 == 0 or note $got2;
+}
+
+1;
diff --git a/cpan/Time-HiRes/t/usleep.t b/cpan/Time-HiRes/t/usleep.t
new file mode 100644
index 0000000000..0d6bacfac3
--- /dev/null
+++ b/cpan/Time-HiRes/t/usleep.t
@@ -0,0 +1,78 @@
+use strict;
+
+BEGIN {
+ require Time::HiRes;
+ unless(&Time::HiRes::d_usleep) {
+ require Test::More;
+ Test::More::plan(skip_all => "no usleep()");
+ }
+}
+
+use Test::More 0.82 tests => 6;
+use t::Watchdog;
+
+eval { Time::HiRes::usleep(-2) };
+like $@, qr/::usleep\(-2\): negative time not invented yet/,
+ "negative time error";
+
+my $limit = 0.25; # 25% is acceptable slosh for testing timers
+
+my $one = CORE::time;
+Time::HiRes::usleep(10_000);
+my $two = CORE::time;
+Time::HiRes::usleep(10_000);
+my $three = CORE::time;
+ok $one == $two || $two == $three
+or note "slept too long, $one $two $three";
+
+SKIP: {
+ skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday;
+ my $f = Time::HiRes::time();
+ Time::HiRes::usleep(500_000);
+ my $f2 = Time::HiRes::time();
+ my $d = $f2 - $f;
+ ok $d > 0.4 && $d < 0.9 or note "slept $d secs $f to $f2";
+}
+
+SKIP: {
+ skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday;
+ my $r = [ Time::HiRes::gettimeofday() ];
+ Time::HiRes::sleep( 0.5 );
+ my $f = Time::HiRes::tv_interval $r;
+ ok $f > 0.4 && $f < 0.9 or note "slept $f instead of 0.5 secs.";
+}
+
+SKIP: {
+ skip "no gettimeofday", 2 unless &Time::HiRes::d_gettimeofday;
+
+ my ($t0, $td);
+
+ my $sleep = 1.5; # seconds
+ my $msg;
+
+ $t0 = Time::HiRes::gettimeofday();
+ $a = abs(Time::HiRes::sleep($sleep) / $sleep - 1.0);
+ $td = Time::HiRes::gettimeofday() - $t0;
+ my $ratio = 1.0 + $a;
+
+ $msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
+
+ SKIP: {
+ skip $msg, 1 unless $td < $sleep * (1 + $limit);
+ ok $a < $limit or note $msg;
+ }
+
+ $t0 = Time::HiRes::gettimeofday();
+ $a = abs(Time::HiRes::usleep($sleep * 1E6) / ($sleep * 1E6) - 1.0);
+ $td = Time::HiRes::gettimeofday() - $t0;
+ $ratio = 1.0 + $a;
+
+ $msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
+
+ SKIP: {
+ skip $msg, 1 unless $td < $sleep * (1 + $limit);
+ ok $a < $limit or note $msg;
+ }
+}
+
+1;
diff --git a/t/TEST b/t/TEST
index 626b70eec8..0c24c179fa 100755
--- a/t/TEST
+++ b/t/TEST
@@ -74,7 +74,6 @@ my %temp_no_core =
'../cpan/podlators' => 1,
'../cpan/Test-Simple' => 1,
'../cpan/Tie-RefHash' => 1,
- '../cpan/Time-HiRes' => 1,
'../cpan/Unicode-Collate' => 1,
'../cpan/Unicode-Normalize' => 1,
);
View Lorry Controller Status