update Time-HiRes to CPAN version 1.9724
authorZefram <zefram@fysh.org>
Tue, 21 Jun 2011 13:52:32 +0000 (14:52 +0100)
committerZefram <zefram@fysh.org>
Tue, 21 Jun 2011 14:58:41 +0000 (15:58 +0100)
- 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.

20 files changed:
MANIFEST
Porting/Maintainers.pl
cpan/Time-HiRes/Changes
cpan/Time-HiRes/HiRes.pm
cpan/Time-HiRes/HiRes.xs
cpan/Time-HiRes/Makefile.PL
cpan/Time-HiRes/t/HiRes.t [deleted file]
cpan/Time-HiRes/t/Watchdog.pm [new file with mode: 0644]
cpan/Time-HiRes/t/alarm.t [new file with mode: 0644]
cpan/Time-HiRes/t/clock.t [new file with mode: 0644]
cpan/Time-HiRes/t/gettimeofday.t [new file with mode: 0644]
cpan/Time-HiRes/t/itimer.t [new file with mode: 0644]
cpan/Time-HiRes/t/nanosleep.t [new file with mode: 0644]
cpan/Time-HiRes/t/sleep.t [new file with mode: 0644]
cpan/Time-HiRes/t/stat.t [new file with mode: 0644]
cpan/Time-HiRes/t/time.t [new file with mode: 0644]
cpan/Time-HiRes/t/tv_interval.t [new file with mode: 0644]
cpan/Time-HiRes/t/ualarm.t [new file with mode: 0644]
cpan/Time-HiRes/t/usleep.t [new file with mode: 0644]
t/TEST

index 777874f..bde5b69 100644 (file)
--- 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
index ef4293f..efbd9bd 100755 (executable)
@@ -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',
        },
index 0515b8f..206fa75 100644 (file)
@@ -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
index e6295a8..30f954a 100644 (file)
@@ -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/.*:://;
index 970baa1..32ac768 100644 (file)
@@ -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;
index 7766f29..6f6a790 100644 (file)
@@ -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 (file)
index 0a38e78..0000000
+++ /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 (file)
index 0000000..83e8543
--- /dev/null
@@ -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 (file)
index 0000000..841694f
--- /dev/null
@@ -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 (file)
index 0000000..6d11dd2
--- /dev/null
@@ -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 (file)
index 0000000..8f7c5f3
--- /dev/null
@@ -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 (file)
index 0000000..7877f63
--- /dev/null
@@ -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 (file)
index 0000000..aef9db6
--- /dev/null
@@ -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 (file)
index 0000000..e7cc627
--- /dev/null
@@ -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 (file)
index 0000000..406fdc3
--- /dev/null
@@ -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 (file)
index 0000000..feec479
--- /dev/null
@@ -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 (file)
index 0000000..bffcf39
--- /dev/null
@@ -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 (file)
index 0000000..12ef4b5
--- /dev/null
@@ -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 (file)
index 0000000..0d6bacf
--- /dev/null
@@ -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 626b70e..0c24c17 100755 (executable)
--- 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,
     );